diff -Nru ddclient-3.9.1/autogen ddclient-3.10.0/autogen --- ddclient-3.9.1/autogen 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/autogen 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,24 @@ +#!/bin/sh + +pecho() { printf %s\\n "$*"; } +log() { pecho "$@"; } +error() { log "ERROR: $@" >&2; } +fatal() { error "$@"; exit 1; } +try() { "$@" || fatal "'$@' failed"; } + +try cd "${0%/*}" +try mkdir -p m4 build-aux +try autoreconf -fviW all + +# Ignore changes to build-aux/tap-driver, but only if we're in a clone +# of the ddclient Git repository. Once CentOS 6 and RHEL 6 reach +# end-of-life we can delete build-aux/tap-driver.sh and this block of +# code. (tap-driver.sh is checked in to this Git repository only +# because we want to support all currently maintained CentOS and RHEL +# releases, and CentoOS 6 and RHEL 6 ship with Automake 1.11 which +# does not come with tap-driver.sh.) +command -v git >/dev/null || exit 0 +git rev-parse --is-inside-work-tree >/dev/null 2>&1 || exit 0 +cdup=$(try git rev-parse --show-cdup) || exit 1 +[ -z "${cdup}" ] || exit 0 +try git update-index --assume-unchanged -- build-aux/tap-driver.sh diff -Nru ddclient-3.9.1/build-aux/tap-driver.sh ddclient-3.10.0/build-aux/tap-driver.sh --- ddclient-3.9.1/build-aux/tap-driver.sh 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/build-aux/tap-driver.sh 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,651 @@ +#! /bin/sh +# Copyright (C) 2011-2020 Free Software Foundation, Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# This file is maintained in Automake, please report +# bugs to or send patches to +# . + +scriptversion=2013-12-23.17; # UTC + +# Make unconditional expansion of undefined variables an error. This +# helps a lot in preventing typo-related bugs. +set -u + +me=tap-driver.sh + +fatal () +{ + echo "$me: fatal: $*" >&2 + exit 1 +} + +usage_error () +{ + echo "$me: $*" >&2 + print_usage >&2 + exit 2 +} + +print_usage () +{ + cat < + # + trap : 1 3 2 13 15 + if test $merge -gt 0; then + exec 2>&1 + else + exec 2>&3 + fi + "$@" + echo $? + ) | LC_ALL=C ${AM_TAP_AWK-awk} \ + -v me="$me" \ + -v test_script_name="$test_name" \ + -v log_file="$log_file" \ + -v trs_file="$trs_file" \ + -v expect_failure="$expect_failure" \ + -v merge="$merge" \ + -v ignore_exit="$ignore_exit" \ + -v comments="$comments" \ + -v diag_string="$diag_string" \ +' +# TODO: the usages of "cat >&3" below could be optimized when using +# GNU awk, and/on on systems that supports /dev/fd/. + +# Implementation note: in what follows, `result_obj` will be an +# associative array that (partly) simulates a TAP result object +# from the `TAP::Parser` perl module. + +## ----------- ## +## FUNCTIONS ## +## ----------- ## + +function fatal(msg) +{ + print me ": " msg | "cat >&2" + exit 1 +} + +function abort(where) +{ + fatal("internal error " where) +} + +# Convert a boolean to a "yes"/"no" string. +function yn(bool) +{ + return bool ? "yes" : "no"; +} + +function add_test_result(result) +{ + if (!test_results_index) + test_results_index = 0 + test_results_list[test_results_index] = result + test_results_index += 1 + test_results_seen[result] = 1; +} + +# Whether the test script should be re-run by "make recheck". +function must_recheck() +{ + for (k in test_results_seen) + if (k != "XFAIL" && k != "PASS" && k != "SKIP") + return 1 + return 0 +} + +# Whether the content of the log file associated to this test should +# be copied into the "global" test-suite.log. +function copy_in_global_log() +{ + for (k in test_results_seen) + if (k != "PASS") + return 1 + return 0 +} + +function get_global_test_result() +{ + if ("ERROR" in test_results_seen) + return "ERROR" + if ("FAIL" in test_results_seen || "XPASS" in test_results_seen) + return "FAIL" + all_skipped = 1 + for (k in test_results_seen) + if (k != "SKIP") + all_skipped = 0 + if (all_skipped) + return "SKIP" + return "PASS"; +} + +function stringify_result_obj(result_obj) +{ + if (result_obj["is_unplanned"] || result_obj["number"] != testno) + return "ERROR" + + if (plan_seen == LATE_PLAN) + return "ERROR" + + if (result_obj["directive"] == "TODO") + return result_obj["is_ok"] ? "XPASS" : "XFAIL" + + if (result_obj["directive"] == "SKIP") + return result_obj["is_ok"] ? "SKIP" : COOKED_FAIL; + + if (length(result_obj["directive"])) + abort("in function stringify_result_obj()") + + return result_obj["is_ok"] ? COOKED_PASS : COOKED_FAIL +} + +function decorate_result(result) +{ + color_name = color_for_result[result] + if (color_name) + return color_map[color_name] "" result "" color_map["std"] + # If we are not using colorized output, or if we do not know how + # to colorize the given result, we should return it unchanged. + return result +} + +function report(result, details) +{ + if (result ~ /^(X?(PASS|FAIL)|SKIP|ERROR)/) + { + msg = ": " test_script_name + add_test_result(result) + } + else if (result == "#") + { + msg = " " test_script_name ":" + } + else + { + abort("in function report()") + } + if (length(details)) + msg = msg " " details + # Output on console might be colorized. + print decorate_result(result) msg + # Log the result in the log file too, to help debugging (this is + # especially true when said result is a TAP error or "Bail out!"). + print result msg | "cat >&3"; +} + +function testsuite_error(error_message) +{ + report("ERROR", "- " error_message) +} + +function handle_tap_result() +{ + details = result_obj["number"]; + if (length(result_obj["description"])) + details = details " " result_obj["description"] + + if (plan_seen == LATE_PLAN) + { + details = details " # AFTER LATE PLAN"; + } + else if (result_obj["is_unplanned"]) + { + details = details " # UNPLANNED"; + } + else if (result_obj["number"] != testno) + { + details = sprintf("%s # OUT-OF-ORDER (expecting %d)", + details, testno); + } + else if (result_obj["directive"]) + { + details = details " # " result_obj["directive"]; + if (length(result_obj["explanation"])) + details = details " " result_obj["explanation"] + } + + report(stringify_result_obj(result_obj), details) +} + +# `skip_reason` should be empty whenever planned > 0. +function handle_tap_plan(planned, skip_reason) +{ + planned += 0 # Avoid getting confused if, say, `planned` is "00" + if (length(skip_reason) && planned > 0) + abort("in function handle_tap_plan()") + if (plan_seen) + { + # Error, only one plan per stream is acceptable. + testsuite_error("multiple test plans") + return; + } + planned_tests = planned + # The TAP plan can come before or after *all* the TAP results; we speak + # respectively of an "early" or a "late" plan. If we see the plan line + # after at least one TAP result has been seen, assume we have a late + # plan; in this case, any further test result seen after the plan will + # be flagged as an error. + plan_seen = (testno >= 1 ? LATE_PLAN : EARLY_PLAN) + # If testno > 0, we have an error ("too many tests run") that will be + # automatically dealt with later, so do not worry about it here. If + # $plan_seen is true, we have an error due to a repeated plan, and that + # has already been dealt with above. Otherwise, we have a valid "plan + # with SKIP" specification, and should report it as a particular kind + # of SKIP result. + if (planned == 0 && testno == 0) + { + if (length(skip_reason)) + skip_reason = "- " skip_reason; + report("SKIP", skip_reason); + } +} + +function extract_tap_comment(line) +{ + if (index(line, diag_string) == 1) + { + # Strip leading `diag_string` from `line`. + line = substr(line, length(diag_string) + 1) + # And strip any leading and trailing whitespace left. + sub("^[ \t]*", "", line) + sub("[ \t]*$", "", line) + # Return what is left (if any). + return line; + } + return ""; +} + +# When this function is called, we know that line is a TAP result line, +# so that it matches the (perl) RE "^(not )?ok\b". +function setup_result_obj(line) +{ + # Get the result, and remove it from the line. + result_obj["is_ok"] = (substr(line, 1, 2) == "ok" ? 1 : 0) + sub("^(not )?ok[ \t]*", "", line) + + # If the result has an explicit number, get it and strip it; otherwise, + # automatically assing the next progresive number to it. + if (line ~ /^[0-9]+$/ || line ~ /^[0-9]+[^a-zA-Z0-9_]/) + { + match(line, "^[0-9]+") + # The final `+ 0` is to normalize numbers with leading zeros. + result_obj["number"] = substr(line, 1, RLENGTH) + 0 + line = substr(line, RLENGTH + 1) + } + else + { + result_obj["number"] = testno + } + + if (plan_seen == LATE_PLAN) + # No further test results are acceptable after a "late" TAP plan + # has been seen. + result_obj["is_unplanned"] = 1 + else if (plan_seen && testno > planned_tests) + result_obj["is_unplanned"] = 1 + else + result_obj["is_unplanned"] = 0 + + # Strip trailing and leading whitespace. + sub("^[ \t]*", "", line) + sub("[ \t]*$", "", line) + + # This will have to be corrected if we have a "TODO"/"SKIP" directive. + result_obj["description"] = line + result_obj["directive"] = "" + result_obj["explanation"] = "" + + if (index(line, "#") == 0) + return # No possible directive, nothing more to do. + + # Directives are case-insensitive. + rx = "[ \t]*#[ \t]*([tT][oO][dD][oO]|[sS][kK][iI][pP])[ \t]*" + + # See whether we have the directive, and if yes, where. + pos = match(line, rx "$") + if (!pos) + pos = match(line, rx "[^a-zA-Z0-9_]") + + # If there was no TAP directive, we have nothing more to do. + if (!pos) + return + + # Let`s now see if the TAP directive has been escaped. For example: + # escaped: ok \# SKIP + # not escaped: ok \\# SKIP + # escaped: ok \\\\\# SKIP + # not escaped: ok \ # SKIP + if (substr(line, pos, 1) == "#") + { + bslash_count = 0 + for (i = pos; i > 1 && substr(line, i - 1, 1) == "\\"; i--) + bslash_count += 1 + if (bslash_count % 2) + return # Directive was escaped. + } + + # Strip the directive and its explanation (if any) from the test + # description. + result_obj["description"] = substr(line, 1, pos - 1) + # Now remove the test description from the line, that has been dealt + # with already. + line = substr(line, pos) + # Strip the directive, and save its value (normalized to upper case). + sub("^[ \t]*#[ \t]*", "", line) + result_obj["directive"] = toupper(substr(line, 1, 4)) + line = substr(line, 5) + # Now get the explanation for the directive (if any), with leading + # and trailing whitespace removed. + sub("^[ \t]*", "", line) + sub("[ \t]*$", "", line) + result_obj["explanation"] = line +} + +function get_test_exit_message(status) +{ + if (status == 0) + return "" + if (status !~ /^[1-9][0-9]*$/) + abort("getting exit status") + if (status < 127) + exit_details = "" + else if (status == 127) + exit_details = " (command not found?)" + else if (status >= 128 && status <= 255) + exit_details = sprintf(" (terminated by signal %d?)", status - 128) + else if (status > 256 && status <= 384) + # We used to report an "abnormal termination" here, but some Korn + # shells, when a child process die due to signal number n, can leave + # in $? an exit status of 256+n instead of the more standard 128+n. + # Apparently, both behaviours are allowed by POSIX (2008), so be + # prepared to handle them both. See also Austing Group report ID + # 0000051 + exit_details = sprintf(" (terminated by signal %d?)", status - 256) + else + # Never seen in practice. + exit_details = " (abnormal termination)" + return sprintf("exited with status %d%s", status, exit_details) +} + +function write_test_results() +{ + print ":global-test-result: " get_global_test_result() > trs_file + print ":recheck: " yn(must_recheck()) > trs_file + print ":copy-in-global-log: " yn(copy_in_global_log()) > trs_file + for (i = 0; i < test_results_index; i += 1) + print ":test-result: " test_results_list[i] > trs_file + close(trs_file); +} + +BEGIN { + +## ------- ## +## SETUP ## +## ------- ## + +'"$init_colors"' + +# Properly initialized once the TAP plan is seen. +planned_tests = 0 + +COOKED_PASS = expect_failure ? "XPASS": "PASS"; +COOKED_FAIL = expect_failure ? "XFAIL": "FAIL"; + +# Enumeration-like constants to remember which kind of plan (if any) +# has been seen. It is important that NO_PLAN evaluates "false" as +# a boolean. +NO_PLAN = 0 +EARLY_PLAN = 1 +LATE_PLAN = 2 + +testno = 0 # Number of test results seen so far. +bailed_out = 0 # Whether a "Bail out!" directive has been seen. + +# Whether the TAP plan has been seen or not, and if yes, which kind +# it is ("early" is seen before any test result, "late" otherwise). +plan_seen = NO_PLAN + +## --------- ## +## PARSING ## +## --------- ## + +is_first_read = 1 + +while (1) + { + # Involutions required so that we are able to read the exit status + # from the last input line. + st = getline + if (st < 0) # I/O error. + fatal("I/O error while reading from input stream") + else if (st == 0) # End-of-input + { + if (is_first_read) + abort("in input loop: only one input line") + break + } + if (is_first_read) + { + is_first_read = 0 + nextline = $0 + continue + } + else + { + curline = nextline + nextline = $0 + $0 = curline + } + # Copy any input line verbatim into the log file. + print | "cat >&3" + # Parsing of TAP input should stop after a "Bail out!" directive. + if (bailed_out) + continue + + # TAP test result. + if ($0 ~ /^(not )?ok$/ || $0 ~ /^(not )?ok[^a-zA-Z0-9_]/) + { + testno += 1 + setup_result_obj($0) + handle_tap_result() + } + # TAP plan (normal or "SKIP" without explanation). + else if ($0 ~ /^1\.\.[0-9]+[ \t]*$/) + { + # The next two lines will put the number of planned tests in $0. + sub("^1\\.\\.", "") + sub("[^0-9]*$", "") + handle_tap_plan($0, "") + continue + } + # TAP "SKIP" plan, with an explanation. + else if ($0 ~ /^1\.\.0+[ \t]*#/) + { + # The next lines will put the skip explanation in $0, stripping + # any leading and trailing whitespace. This is a little more + # tricky in truth, since we want to also strip a potential leading + # "SKIP" string from the message. + sub("^[^#]*#[ \t]*(SKIP[: \t][ \t]*)?", "") + sub("[ \t]*$", ""); + handle_tap_plan(0, $0) + } + # "Bail out!" magic. + # Older versions of prove and TAP::Harness (e.g., 3.17) did not + # recognize a "Bail out!" directive when preceded by leading + # whitespace, but more modern versions (e.g., 3.23) do. So we + # emulate the latter, "more modern" behaviour. + else if ($0 ~ /^[ \t]*Bail out!/) + { + bailed_out = 1 + # Get the bailout message (if any), with leading and trailing + # whitespace stripped. The message remains stored in `$0`. + sub("^[ \t]*Bail out![ \t]*", ""); + sub("[ \t]*$", ""); + # Format the error message for the + bailout_message = "Bail out!" + if (length($0)) + bailout_message = bailout_message " " $0 + testsuite_error(bailout_message) + } + # Maybe we have too look for dianogtic comments too. + else if (comments != 0) + { + comment = extract_tap_comment($0); + if (length(comment)) + report("#", comment); + } + } + +## -------- ## +## FINISH ## +## -------- ## + +# A "Bail out!" directive should cause us to ignore any following TAP +# error, as well as a non-zero exit status from the TAP producer. +if (!bailed_out) + { + if (!plan_seen) + { + testsuite_error("missing test plan") + } + else if (planned_tests != testno) + { + bad_amount = testno > planned_tests ? "many" : "few" + testsuite_error(sprintf("too %s tests run (expected %d, got %d)", + bad_amount, planned_tests, testno)) + } + if (!ignore_exit) + { + # Fetch exit status from the last line. + exit_message = get_test_exit_message(nextline) + if (exit_message) + testsuite_error(exit_message) + } + } + +write_test_results() + +exit 0 + +} # End of "BEGIN" block. +' + +# TODO: document that we consume the file descriptor 3 :-( +} 3>"$log_file" + +test $? -eq 0 || fatal "I/O or internal error" + +# Local Variables: +# mode: shell-script +# sh-indentation: 2 +# eval: (add-hook 'before-save-hook 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-time-zone: "UTC0" +# time-stamp-end: "; # UTC" +# End: diff -Nru ddclient-3.9.1/ChangeLog ddclient-3.10.0/ChangeLog --- ddclient-3.9.1/ChangeLog 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/ChangeLog 1970-01-01 00:00:00.000000000 +0000 @@ -1,654 +0,0 @@ -2018-08-09 wimpunk - - * [r208] ddclient: cosmetic, remove stray space indent - * [r207] ddclient: Support IPv6 for CloudFlare - * [r206] ddclient: name cheap support https now - - From name cheap it seems http is supported now. - Since the password was send on plaintext, https should be used - - * [r205] ddclient: Use JSON::PP instead of the (deprecated) - JSON::Any - * [r204] ddclient: Follow expected behavior - - Align ddclient behavior and documentation with namecheap's - - https://www.namecheap.com/support/knowledgebase/article.aspx/583/11/how-do-i-configure-ddclient - - * [r203] ddclient: Specify port number properly to 'nsupdate' (#58) - - If a port number is included in the 'server' configuration item, - ddclient allows a port number to be specified by appending a - colon - and the port number to the server's name or IPv4 address. - However, - nsupdate does not support this syntax, it requires the port - number - to be separated from the server name/address by whitespace. - - Signed-off-by: Kevin P. Fleming - -2017-04-30 wimpunk - - * [r202] README.md, README.ssl, ddclient, sample-etc_ddclient.conf, - sample-etc_rc.d_init.d_ddclient.alpine: Adding support for - freemyip.com - - Support provided by @Cadence-GitHub in by pull request #47 - -2015-10-13 wimpunk - - * [r195] ddclient, sample-etc_ddclient.conf: Merge pull request #25 - from dancapper/master - - Adding configurable TTL to Cloudflare - - This change adds configurable TTL to cloudflare instead of just - using hardcoded value of 1 which sets "automatic" TTL any time - ddclient updates the IP address. - - * [r194] sample-etc_ddclient.conf: Merge pull request #24 from - gkranis/master - - Adding duckdns example - - Duckdns example added to sample-etc_ddclient.conf - - * [r193] README.md, sample-etc_rc.d_init.d_ddclient.ubuntu: Prevent - service to start multiple times. - Added messages if trying to start/stop already started/stopped - service. - Added daemon install instructions for ubuntu. - - * [r192] ddclient: odd-fw-patch-squashed - * [r191] README.md, ddclient: Added support for woima.fi dyndns - service - -2015-09-28 wimpunk - - * [r190] ddclient: Cleanup: removing revision info. - - Removing revision info even when it's just in the comments. - - * [r189] ChangeLog: Adding ChangeLog - - Since we are not going to fetch the changes from svn anymore, - we add the old ChangeLog again. - - * [r188] .cvsignore, .gitignore: Cleanup: removing old ignore files - - Switching to git so we don't need .cvsignore anymore - - * [r187] COPYING: FSF address - - Address for FSF was wrong, corrected - - * [r186] Changelog.old, README.cisco, ddclient, - sample-etc_cron.d_ddclient, sample-etc_ddclient.conf, - sample-etc_dhclient-exit-hooks, sample-etc_dhcpc_dhcpcd-eth0.exe, - sample-etc_ppp_ip-up.local, sample-etc_rc.d_init.d_ddclient.lsb, - sample-etc_rc.d_init.d_ddclient.redhat: Cleanup: removing Id tags - from the files - - Preparing a complete move to git. The Id tag isn't useful so - removing from the files seemed to be the best solotion - -2015-05-28 wimpunk - - * [r183] ., release: Removing unneeded release directory - -2015-03-23 wimpunk - - * [r182] ddclient: Reverting to the old perl requirements like - suggested in #75 - - The new requirements were added when adding support for cloudflare. By the - simple fix suggested by Roy Tam we could revert the requirements which make - ddclient back usable on CentOS and RHEL. - - * [r181] ddclient: ddclient: made json optional - - As suggested in pull 7 on github by @abelbeck and @Bugsbane it is - better to make the - use of JSON related to the use of cloudflare. - - * [r180] ddclient: ddclient: reindenting cloudflare - - Indenting cloudflare according to the vim tags - - * [r179] ddclient: ddclient: correction after duckdns merge - - Correcting duckdns configuration after commit r178 - - * [r178] ddclient: Added simple support for Duckdns www.duckdns.org - - Patch provided by gkranis on github. - Merge branch 'gkranis' - -2015-03-21 wimpunk - - * [r177] README.md: Added duckDNS to the README.md - * [r176] sample-etc_rc.d_init.d_ddclient.ubuntu: update ubuntu init.d script - - Merge pull request #9 from gottaloveit/master - - * [r175] Changelog, Changelog.old: Renamed Changelog to - Changelog.old - - Avoiding conflicts on case insensitive filesystems - - * [r174] ddclient: Add missing config line for CloudFlare - - Merge pull request #19 from shikasta-net/fixes - - * [r173] ddclient: Merge pull request #22 from reddyr/patch-1 - - loopia.se changed the "Current Address:" output string to "Current IP - Address:" - - * [r172] ddclient: fixed missing ) for cloudflare service hash - - Merge pull request #16 from adepretis/master - -2015-01-20 wimpunk - - * [r171] README.md, ddclient, sample-etc_ddclient.conf: Adding - support for google domain - - Patch gently provided through github on - https://github.com/wimpunk/ddclient/pull/13 - -2014-10-08 wimpunk - - * [r170] README.md, ddclient, sample-etc_ddclient.conf: Added - support for Cloudflare and multi domain support for namecheap - - Pull request #7 from @roberthawdon - See https://github.com/wimpunk/ddclient/pull/7 for more info. - -2014-09-09 wimpunk - - * [r169] ddclient: Bugfix: allowing long username-password - combinations - - Patch provided by @dirdi through github. - -2014-08-20 wimpunk - - * [r166] ddclient: Fixing bug #72: Account info revealed during - noip update - - * [r165] ddclient: Interfaces can be named almost anything on - modern systems. - - Patch provided by Stephen Couchman through github - -2014-06-30 wimpunk - - * [r164] ddclient: Only delete A RR, not any RR for the FQDN - - Make the delete command specific to A RRs. This prevents ddclient - from deleting other RRs unrelated to the dynamic address, but on the - same FQDN. This can be specifically a problem with KEY RRs when using - SIG(0) instead of symmetric keys. - - Reported by: Wellie Chao - Bug report: http://sourceforge.net/p/ddclient/bugs/71/ - - Fixes #71 - -2014-06-02 wimpunk - - * [r163] README.md, ddclient: Adding support for nsupdate. - - Patch provided by Daniel Roethlisberger through - github. - -2014-04-29 wimpunk - - * [r162] README.md, README.ssl, ddclient: Removed revision - information - - Revision information isn't very usable when switching to git. - -2014-03-20 wimpunk - - * [r161] README.md, README.ssl, ddclient, - sample-etc_rc.d_init.d_ddclient.alpine: Added Alpine Linux init - script - - Patch send by Tal on github. - - * [r160] RELEASENOTE: Corrected release note - -2013-12-26 wimpunk - - * [r159] release/readme.txt: Commiting updated release information - * [r158] README.md, RELEASENOTE: Committing release notes and - readme information to trunk - -2013-11-05 wimpunk - - * [r156] patches: Moving patching to the root of the repository. - - The patches are mostly there for historical reasons. They've been - moved away to make cleaning easier. I think the applied patches should - even be removed. - -2013-10-28 wimpunk - - * [r155] ddclient: Fallback to iproute if ifconfig doesn't work. - - This fix applies the patch provided by Maccied Grela in [bugs:#26] - - * [r154] ddclient: preventing deep sleep - see [bugs:#46] - - Fixing [bugs:#46] by applying the provided patch. - -2013-07-08 wimpunk - - * [r153] ddclient: Applying patch from [fb1ad014] fixing bug [#14] - - More info can be found on [fb1ad014] and has been discussed in - the mailinglist: - http://article.gmane.org/gmane.network.dns.ddclient.user/71. The - patch was send by Rodrigo Araujo. - -2013-05-14 wimpunk - - * [r152] ddclient: Adding sha1-patch provided by pirast in - [9742ac09] - -2013-04-28 wimpunk - - * [r150] README.md, ddclient, sample-etc_ddclient.conf: Adding - support for ChangeIP based on the patch from Michele Giorato - http://sourceforge.net/p/ddclient/discussion/399428/thread/e85661ad/ - * [r148] README.md: Updated README file - * [r147] ., README, README.md: Applying markdown syntax to README - -2011-07-11 wimpunk - - * [r131] release/readme.txt: Updates after releasing 3.8.1 - * [r129] release/readme.txt: Corrected release/readme.txt - * [r128] sample-etc_ppp_ip-up.local: Applied ip-up_run-parts.diff - from ubuntu - * [r127] ddclient: Applied smc-barricade-fw-alt.diff from ubuntu - -2011-07-03 wimpunk - - * [r126] ddclient: Fixing #28: FreeDNS.afraid.org changed api - slightly - -2011-05-19 wimpunk - - * [r125] ddclient, sample-etc_ddclient.conf: Added patch for - dtdns-support (#39) - -2011-03-09 wimpunk - - * [r124] ddclient: Patching with nic_updateable-warning patch - provided by antespi in ticket #2 - -2011-03-08 wimpunk - - * [r123] ddclient: Patching with zoneedit patch provided by - killer-jk in ticket #15 - -2010-12-07 wimpunk - - * [r122] ddclient: Added longer password support, sended by Ingo - Schwarze (#3130634) - -2010-10-13 wimpunk - - * [r121] ddclient: Fixing bug #13: multiple fetch-ip but - introducing a multiple ip bug - -2010-09-14 wimpunk - - * [r120] ddclient: patch for #10: invalid value for keyword ip - -2010-09-13 wimpunk - - * [r119] ddclient: Applied patch from ticket #8, patch for cache - content leaks to global - * [r118] ddclient: Applied patch from ticket #7, provided by Chris - Carr - -2010-07-01 wimpunk - - * [r117] ddclient: Fixed #6: Add Red Hat package name to Perl - module IO::Socket::SSL error message - -2010-02-24 wimpunk - - * [r116] ddclient: Subversion revision added - -2009-11-09 wimpunk - - * [r115] ddclient, patches/cisco-asa.patch: Added cisco-asa patch - (2891001) submitted by Philip Gladstone - * [r114] ddclient, patches/prevent-hang.patch: Added prevent-hang - patch (2880462) submitted by Panos - -2009-10-19 wimpunk - - * [r113] ddclient, patches/foreground.patch: Added foreground patch - (1893144) submitted by John Palkovic - -2009-09-10 wimpunk - - * [r112] README, ddclient, patches/loopia.patch, - sample-etc_ddclient.conf: #1609799 Support for LoopiaDNS - (submitted by scilence) - -2009-08-05 wimpunk - - * [r111] ddclient, patches/freedns-patch: applied freedns patch - (patch 2832129) - -2009-05-16 wimpunk - - * [r110] ddclient: Bug 2792436: fixed abuse message of dyndns - -2009-02-27 wimpunk - - * [r109] sample-etc_ddclient.conf: Added warning about the update - interval (#2619505) - -2009-01-27 wimpunk - - * [r108] .cvsignore, RELEASENOTE, ddclient, release, - release/readme.txt: Modified during the release of ddclient-3.8.0 - -2008-12-04 wimpunk - - * [r106] ddclient: help about postscript added - -2008-11-19 wimpunk - - * [r105] ddclient, patches/password.patch: Added better password - handling sended by Ingo Schwarze - * [r104] TODO, sample-ddclient-wrapper.sh: Added ddclient wrapper - script - * [r103] ddclient: Extra fix for multiple IP's - -2008-11-01 wimpunk - - * [r102] sample-etc_ddclient.conf: Added some remarks concerning - the postscript. See - https://sourceforge.net/forum/message.php?msg_id=5550545 - -2008-09-30 wimpunk - - * [r101] ddclient, patches/multiple-ip.patch: Added support for - multiple IP adresses. See - http://permalink.gmane.org/gmane.network.dns.ddclient.user/17 - * [r100] patches/namecheap.patch: extra comments added to namecheap - patch - -2008-07-04 wimpunk - - * [r99] patches/namecheap.patch: namecheap patch added to patches - section - -2008-06-13 wimpunk - - * [r98] .: New trunk created based on the old trunk/svn - * [r96] svn: Moved old trunk/svn to ddclient and it will be the new - trunk - * [r95] svn: Ignoring test configuration - * [r94] svn/.cvsignore, svn/RELEASENOTE, svn/UPGRADE: Added some - release related files - * [r93] svn/patches/no-host.patch: Added not used no-host patch to - patches section - -2008-06-05 wimpunk - - * [r90] svn/ddclient: Added more info about the daemon interval - * [r89] svn/ddclient: Preventing error while reading cache when ip - wasn't set correctly before - * [r88] svn/ddclient: Preventing an error when trying to send a - message on mail-failure - -2008-06-02 wimpunk - - * [r87] svn/ddclient, svn/sample-etc_ddclient.conf: Modified - documentation about zoneedit based on the comments from Oren Held - -2008-03-04 wimpunk - - * [r86] svn/patches/ddclient.daemon-timeout.patch: Added patch - which was applied to rev 27 (posted by James deBoer) - -2008-02-19 wimpunk - - * [r85] svn/patches/eurodns.patch: Patch modified to apply on - ddclient 3.7.3 - -2008-02-08 wimpunk - - * [r84] svn/patches/mail-on-kill.patch: Added mail-on-kill patch to - patches section - -2008-02-05 wimpunk - - * [r83] svn/ddclient: Sending mail when killed, not after - TERM-signal - * [r82] svn/README: Added creation of cache dir - -2007-10-29 wimpunk - - * [r81] svn/ddclient, svn/patches/ubuntu/default-timeout.patch: - Added and applied default timeout patch from - https://bugs.launchpad.net/ubuntu/+source/ddclient/+bug/116066 - -2007-08-29 wimpunk - - * [r80] svn/ddclient, svn/patches/ddclient-noip.patch: Added - ddclient-noip.patch send by Kurt Bussche. - -2007-08-07 wimpunk - - * [r78] svn/ddclient: Updated version number to 3.7.3 - -2007-08-01 wimpunk - - * [r77] svn/ddclient, svn/patches/typo_dnspark.patch: Applied - typo_dnspark.patch send by Marco - -2007-07-31 wimpunk - - * [r76] svn/README.ssl: Renamed dyndns.org to dyndns.com - * [r75] svn/README: Removed ^M at line 37 - * [r74] svn/ddclient: Removed line 183, comments on Vigor 2200 USB - -2007-07-30 wimpunk - - * [r73] svn: Ignoring ChangeLog since autogenerated - * [r72] svn/Changelog: Notification about changed ChangeLog - configuration - * [r71] svn/patches/ubuntu/dyndns_com.diff: Removed patch since - it's invalid - * [r70] svn/patches/opendns.patch: Added not applied opendns.patch, - see tracker #1758564 - * [r69] svn/patches/debianpatches, - svn/patches/debianpatches/abuse_msg.diff, - svn/patches/debianpatches/cachedir.diff, - svn/patches/debianpatches/cisco_fw.diff, - svn/patches/debianpatches/config_path.diff, - svn/patches/debianpatches/daemon_check.diff, - svn/patches/debianpatches/daemon_interval.diff, - svn/patches/debianpatches/help_nonroot(2).diff, - svn/patches/debianpatches/help_nonroot.diff, - svn/patches/debianpatches/ip-up_run-parts.diff, - svn/patches/debianpatches/maxinterval.diff, - svn/patches/debianpatches/readme.txt, - svn/patches/debianpatches/sample_path.diff, - svn/patches/debianpatches/smc-barricade-7401bra.patch, - svn/patches/debianpatches/smc-barricade-fw-alt.diff, - svn/patches/debianpatches/update-new-config.patch, - svn/patches/ubuntu, svn/patches/ubuntu/checked_ssl_load.diff, - svn/patches/ubuntu/config_path.diff, - svn/patches/ubuntu/daemon_interval.diff, - svn/patches/ubuntu/dyndns_com.diff, - svn/patches/ubuntu/sample_ubuntu.diff, svn/patches/ubuntu/series, - svn/patches/ubuntu/smc-barricade-fw-alt.diff: Added debian and - ubuntu patches - -2007-07-29 wimpunk - - * [r68] svn/TODO: Added url to feature request dyndns - -2007-07-12 wimpunk - - * [r67] svn/README, svn/patches/readme.patch: Run dos2unix on - readme and it's patch which Marco Rodrigues submitted. - * [r66] svn/README, svn/patches/readme.patch: Partial applied - readme.patch. See tracker #1752931 - -2007-07-10 wimpunk - - * [r65] svn/ddclient: signature modified - * [r64] svn/ddclient: Added website to ddclient comments - * [r63] svn/patches/regex_vlan.patch: Added extra comments to the - patch. - * [r62] svn/ddclient, svn/patches/create_patch.sh, - svn/patches/regex_vlan.patch, - svn/patches/typo_namecheap_patch.diff.new: Added patches and - applied regex_vlan.patch. See bug #1747337 - * [r61] svn/ddclient: Applied typo_namecheap_patch.diff send by - Marco Rodrigues - -2007-07-07 wimpunk - - * [r60] svn/sample-etc_ppp_ip-up.local: Reverted the patch from - torsten. See [ 1749470 ] Bug in Script sample-etc_ppp_ip-up.local - -2007-07-04 wimpunk - - * [r59] svn/release, svn/release/readme.txt: Adding some release - documentation - -2007-06-14 wimpunk - - * [r57] svn/Changelog, svn/ddclient: Changed version number - * [r55] svn/patches, svn/patches/3com-oc-remote812.patch, - svn/patches/easydns.patch, svn/patches/eurodns.patch: Patches - directory added - -2007-06-12 wimpunk - - * [r54] svn/ddclient: 3com-oc-remote812 patch by The_Beast via IRC: - see patches/3com-oc-remote812.patch - -2007-06-05 wimpunk - - * [r53] svn/ddclient: Applied easydns.patch, patch 117054 - -2007-05-28 wimpunk - - * [r52] svn/ddclient: Changed nic_namecheap_update following the - suggestion of edmdude on the forum - (https://sourceforge.net/forum/message.php?msg_id=4316938) - -2007-05-19 wimpunk - - * [r48] svn/ddclient: Cosmetic change about checkip - * [r47] svn/ddclient: Applied checked_ssl_load.diff from ubuntu - * [r46] svn/ddclient: Removed the two empty lines at the end of - ddclient - -2007-02-26 wimpunk - - * [r44] svn/TODO: added a TODO list - -2007-02-21 wimpunk - - * [r43] svn/Changelog, svn/ddclient: Preventing unitialized values, - check https://sourceforge.net/forum/message.php?msg_id=4167772 - -2007-01-24 wimpunk - - * [r40] svn/Changelog, svn/ddclient: Changed max-interval to - 25days. See https://www.dyndns.com/services/dns/dyndns/faq.html - -2006-12-03 wimpunk - - * [r39] svn/Changelog, svn/ddclient: Applied maxinterval.diff: - Increase max interval for updates. - See http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=129370 - http://www.dyndns.com/support/services/dyndns/faq.html#q15 - * [r38] svn/ddclient: Applied cisco_fw.diff: Use configured - hostname for firewall access with - -use=cisco (closes: #345712). Thanks to Per Carlson for the - patch! - See http://bugs.debian.org/345712. - -2006-12-02 wimpunk - - * [r37] svn/Changelog, svn/ddclient: Applied - smc-barricade-7401bra.patch: Support for SMC Barricade 7401BRA FW - firewall (submitted by Torsten) - Changelog modified for all previous patches from Torsten - * [r36] svn/ddclient: Applied update-new-config.patch: Force update - if config has changed - (submitted by Torsten) - * [r35] svn/sample-etc_ppp_ip-up.local: Applied - ip-up_run-parts.diff: Fix parameter in ip-up script. - (submitted by Torsten) - * [r34] svn/ddclient: Applied help_nonroot.diff: Allow calling the - help function as non-root. - (submitted by Torsten) - * [r33] svn/ddclient: Applied cachedir.diff: Original ddclient - stores a cache file in /etc which - would belong in /var/cache in my opinion and according to the - FHS. Patch - changes that. (submitted by Torsten) - * [r32] svn/ddclient: Applied abuse_msg.diff: ddclient still - reports the email to contact dyndns.org - but they prefer a web form today (IIRC). This patch adjusts the - abuse warning - printed by ddclient. (submitted by Torsten) - * [r31] svn/Changelog: Changed Changelog syntax - -2006-11-27 wimpunk - - * [r30] svn/Changelog, svn/ddclient: Don't send any mail when in - not running daemon mode (patch submitted by Daniel Thaler) - -2006-11-03 wimpunk - - * [r28] svn/Changelog, svn/ddclient: Added patch "Patch: Treat - --daemon values as intervals" - (submitted by James deBoer) - -2006-09-30 wimpunk - - * [r22] svn/Changelog, svn/sample-etc_rc.d_init.d_ddclient.ubuntu: - Added initscript for Ubuntu (posted by Paolo Martinelli) - -2006-09-14 wimpunk - - * [r21] svn/Changelog, svn/ddclient: URL of zoneedit has changed - (see bug #1558483) - -2006-06-14 wimpunk - - * [r11] svn/Changelog, svn/ddclient: Changed version number - * [r8] ., html, svn, xml: Created trunk and tags, moved directories - to it - * [r6] Changed the order of perl and update of README.ssl - -2006-06-11 ddfisher - - * [r5] see Changelog - -2006-06-10 ddfisher - - * [r4] updated changelog - * [r3] See Changelog - -2006-05-22 wimpunk - - * [r2] Reorganise diff -Nru ddclient-3.9.1/ChangeLog.md ddclient-3.10.0/ChangeLog.md --- ddclient-3.9.1/ChangeLog.md 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/ChangeLog.md 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,904 @@ +# ChangeLog + +This document describes notable changes. For details, see the [source code +repository history](https://github.com/ddclient/ddclient/commits/master). + +## 2022-10-20 v3.10.0 +### New features + + * Added support for domaindiscount24.com + * Added support for njal.la + +## 2022-05-15 v3.10.0_2 + +### Bug fixes + * Fix version number being unable to parse + +## 2022-05-15 v3.10.0_1 + +This release contains a total of over 360 commits according to GitHub. +Many of them cleaned up and improved the code to make further maintenance easier. +ddclient also went through a major maintainer change. More help is highly appreciated +and for the time new features are unlikely to be implemented. +This is a first release candidate to hopefully catch some more bugs before the final 3.10.0 release. +Due to ddclient's nature talking to many cloud services, testing all of them is not easy +and it is necessary to rely on the community to test all of them. + +### New features + + * Added support for Cloudflare API tokens + * Added support for OVH DynHost. + * Added support for ClouDNS. + * Added support for dinahosting. + * Added support for Gandi LiveDNS. + * Added a build system to make it easier for distributions to package + ddclient: + ``` + ./autogen && ./configure && make && make VERBOSE=1 check && make install + ``` + * The `freedns` protocol (for https://freedns.afraid.org) now supports IPv6 + addresses. + * New `ssl_ca_dir` and `ssl_ca_file` options to specify the location of CA + certificates. + * New built-in IP discovery service shorthands: + - `googledomains` from https://domains.google + - `he` from https://he.net + - `ip4only.me`, `ip6only.me` from http://whatismyv6.com + - `ipify-ipv4` and `ipify-ipv6` from https://www.ipify.org + - `myonlineportal` from https://myonlineportal.net + - `noip-ipv4` and `noip-ipv6` from https://www.noip.com + - `nsupdate.info-ipv4` and `nsupdate.info-ipv6` from + https://www.nsupdate.info + - `zoneedit` from https://www.zoneedit.com + * New built-in shorthands for obtaining the IP address from the following + devices ([thanks to Geoff Simmons](https://bugs.debian.org/589980)): + - `alcatel-530`: Alcatel/Thomson SpeedTouch 530 + - `siemens-ss4200`: Siemens SpeedStream 4200 + - `thomson-st536v6`: Thomson SpeedTouch 536v6 + - `thomson-tg782`: Thomson/Technicolor TG782 + * Added option `-curl` to access network with system Curl command instead + of the Perl built-in IO::Socket classes. + * Added option `-{no}web-ssl-validate` and `-{no}fw-ssl-validate`to provide + option to disable SSL certificate validation. Note that these only apply for + network access when obtaining an IP address with `use=web` or `use=fw` + (any firewall). Network access to Dynamic DNS servers to set or retrieve + IP address will always require certificate validation. + +### Bug fixes + + * If multiple hosts are defined and one fails, ddclient will no longer skip + the remaining hosts. + * Minor `freedns` protocol fixes. In particular, you can now update an + address that differs from the system's own. + * Fixed a regression introduced in v3.9.0 that caused + `use=ip,ip=` to fail. + * "true" is now accepted as a boolean value. + * The `ssl` option now applies to the `web` URL. + +### Compatibility and dependency changes + + * Perl v5.10.1 or later is now required. + * Removed dependency on Data::Validate::IP. + * When `use=if`, iproute2's `ip` command is now attempted before falling back + to `ifconfig` (it used to be the other way around). If you set `if-skip`, + please check that your configuration still works as expected. + * Removed the `concont` protocol. If you still use this protocol, please + [file a bug report](https://github.com/ddclient/ddclient/issues) and we + will restore it. + * The `force` option no longer prevents daemonization. + * If installed as `ddclientd` (or any other name ending in `d`), the default + value for the `daemon` option is now 5 minutes instead of the previous 1 + minute. + * The `pid` option is now ignored when ddclient is not daemonized. + * ddclient now gracefully exits when interrupted by Ctrl-C. + * The way ddclient chooses the default for the `use` option has changed. + Rather than rely on the default, users should explicitly set the `use` + option. + * The default `interval` changed from 1 minute to 5 minutes. + * The `fw-banlocal` option is deprecated and no longer does anything. + * The `if-skip` option is deprecated and no longer does anything. + * The default server for the `dslreports1` protocol changed from + `members.dyndns.org` to `www.dslreports.com`. + * Removed support for defunct dnsspark service + * Removed support for defunct dtdns service + * Removed support for defunct Hammernode service + +## 2020-01-08 v3.9.1 + + * added support for Yandex.Mail for Domain DNS service + * added support for NearlyFreeSpeech.net + * added support for DNS Made Easy + * added systemd instructions + * added support for dondominio.com + * updated perl instruction + * updated fritzbox instructions + * fixed multidomain support for namecheap + * fixed support for Yandex + +## 2018-08-09 v3.9.0 + + * new dependency: Data::Validate::IP + * added IPv6 support for cloudfare + * added suppport for freemyip + * added configurable TTL to Cloudflare + * added support for woima.fi dyndns service + * added support for google domain + +### Detailed list of changes + + * [r208] wimpunk: ddclient: cosmetic, remove stray space indent + * [r207] wimpunk: ddclient: Support IPv6 for CloudFlare + * [r206] wimpunk: ddclient: name cheap support https now + + From name cheap it seems http is supported now. Since the password was + send on plaintext, https should be used + * [r205] wimpunk: ddclient: Use JSON::PP instead of the (deprecated) + JSON::Any + * [r204] wimpunk: ddclient: Follow expected behavior + + Align ddclient behavior and documentation with namecheap's - + https://www.namecheap.com/support/knowledgebase/article.aspx/583/11/how-do-i-configure-ddclient + * [r203] wimpunk: ddclient: Specify port number properly to 'nsupdate' (#58) + + If a port number is included in the 'server' configuration item, ddclient + allows a port number to be specified by appending a colon and the port + number to the server's name or IPv4 address. However, nsupdate does not + support this syntax, it requires the port number to be separated from the + server name/address by whitespace. + + Signed-off-by: Kevin P. Fleming + * [r202] wimpunk: README.md, README.ssl, ddclient, sample-etc_ddclient.conf, + sample-etc_rc.d_init.d_ddclient.alpine: Adding support for freemyip.com + + Support provided by @Cadence-GitHub in by pull request #47 + * [r195] wimpunk: ddclient, sample-etc_ddclient.conf: Merge pull request #25 + from dancapper/master + + Adding configurable TTL to Cloudflare + + This change adds configurable TTL to cloudflare instead of just using + hardcoded value of 1 which sets "automatic" TTL any time ddclient updates + the IP address. + * [r194] wimpunk: sample-etc_ddclient.conf: Merge pull request #24 from + gkranis/master + + Adding duckdns example + + Duckdns example added to sample-etc_ddclient.conf + * [r193] wimpunk: README.md, sample-etc_rc.d_init.d_ddclient.ubuntu: Prevent + service to start multiple times. Added messages if trying to start/stop + already started/stopped service. Added daemon install instructions for + ubuntu. + * [r192] wimpunk: ddclient: odd-fw-patch-squashed + * [r191] wimpunk: README.md, ddclient: Added support for woima.fi dyndns + service + * [r190] wimpunk: ddclient: Cleanup: removing revision info. + + Removing revision info even when it's just in the comments. + * [r189] wimpunk: ChangeLog: Adding ChangeLog + + Since we are not going to fetch the changes from svn anymore, we add the + old ChangeLog again. + * [r188] wimpunk: .cvsignore, .gitignore: Cleanup: removing old ignore files + + Switching to git so we don't need .cvsignore anymore + * [r187] wimpunk: COPYING: FSF address + + Address for FSF was wrong, corrected + * [r186] wimpunk: Changelog.old, README.cisco, ddclient, + sample-etc_cron.d_ddclient, sample-etc_ddclient.conf, + sample-etc_dhclient-exit-hooks, sample-etc_dhcpc_dhcpcd-eth0.exe, + sample-etc_ppp_ip-up.local, sample-etc_rc.d_init.d_ddclient.lsb, + sample-etc_rc.d_init.d_ddclient.redhat: Cleanup: removing Id tags from the + files + + Preparing a complete move to git. The Id tag isn't useful so removing from + the files seemed to be the best solotion + +## 2015-05-28 v3.8.3 + + * added Alpine Linux init script - patch sent by @Tal on github. + * added support for nsupdate - patch sent by @droe on github + * allow log username-password combinations - patch sent by @dirdi on github + * adding support for cloudflare - patch sent by @roberthawdon on github + * adding support for duckdns - patch sent by @gkranis + +### Detailed list of changes + + * [r183] wimpunk: ., release: Removing unneeded release directory + * [r182] wimpunk: ddclient: Reverting to the old perl requirements like + suggested in #75 + + The new requirements were added when adding support for cloudflare. By the + simple fix suggested by Roy Tam we could revert the requirements which make + ddclient back usable on CentOS and RHEL. + * [r181] wimpunk: ddclient: ddclient: made json optional + + As suggested in pull 7 on github by @abelbeck and @Bugsbane it is better to + make the use of JSON related to the use of cloudflare. + * [r180] wimpunk: ddclient: ddclient: reindenting cloudflare + + Indenting cloudflare according to the vim tags + * [r179] wimpunk: ddclient: ddclient: correction after duckdns merge + + Correcting duckdns configuration after commit r178 + * [r178] wimpunk: ddclient: Added simple support for Duckdns www.duckdns.org + + Patch provided by gkranis on github. Merge branch 'gkranis' + * [r177] wimpunk: README.md: Added duckDNS to the README.md + * [r176] wimpunk: sample-etc_rc.d_init.d_ddclient.ubuntu: update ubuntu + init.d script + + Merge pull request #9 from gottaloveit/master + * [r175] wimpunk: Changelog, Changelog.old: Renamed Changelog to + Changelog.old + + Avoiding conflicts on case insensitive filesystems + * [r174] wimpunk: ddclient: Add missing config line for CloudFlare + + Merge pull request #19 from shikasta-net/fixes + * [r173] wimpunk: ddclient: Merge pull request #22 from reddyr/patch-1 + + loopia.se changed the "Current Address:" output string to "Current IP + Address:" + * [r172] wimpunk: ddclient: fixed missing ) for cloudflare service hash + + Merge pull request #16 from adepretis/master + * [r171] wimpunk: README.md, ddclient, sample-etc_ddclient.conf: Adding + support for google domain + + Patch gently provided through github on + https://github.com/wimpunk/ddclient/pull/13 + * [r170] wimpunk: README.md, ddclient, sample-etc_ddclient.conf: Added + support for Cloudflare and multi domain support for namecheap + + Pull request #7 from @roberthawdon See + https://github.com/wimpunk/ddclient/pull/7 for more info. + * [r169] wimpunk: ddclient: Bugfix: allowing long username-password + combinations + + Patch provided by @dirdi through github. + * [r166] wimpunk: ddclient: Fixing bug #72: Account info revealed during noip + update + * [r165] wimpunk: ddclient: Interfaces can be named almost anything on modern + systems. + + Patch provided by Stephen Couchman through github + * [r164] wimpunk: ddclient: Only delete A RR, not any RR for the FQDN + + Make the delete command specific to A RRs. This prevents ddclient from + deleting other RRs unrelated to the dynamic address, but on the same + FQDN. This can be specifically a problem with KEY RRs when using SIG(0) + instead of symmetric keys. + + Reported by: Wellie Chao Bug report: + http://sourceforge.net/p/ddclient/bugs/71/ + + Fixes #71 + * [r163] wimpunk: README.md, ddclient: Adding support for nsupdate. + + Patch provided by Daniel Roethlisberger through github. + * [r162] wimpunk: README.md, README.ssl, ddclient: Removed revision + information + + Revision information isn't very usable when switching to git. + * [r161] wimpunk: README.md, README.ssl, ddclient, + sample-etc_rc.d_init.d_ddclient.alpine: Added Alpine Linux init script + + Patch send by Tal on github. + * [r160] wimpunk: RELEASENOTE: Corrected release note + * [r159] wimpunk: release/readme.txt: Commiting updated release information + * [r158] wimpunk: README.md, RELEASENOTE: Committing release notes and readme + information to trunk + +## 2013-12-26 v3.8.2 + + * added support by ChangeIP - patch sent by Michele Giorato + * sha-1 patch sent by pirast to allow Digest::SHA + * allow reuse of use - patch sent by Rodrigo Araujo + * preventing deep sleep - see [SourceForge bug + #46](https://sourceforge.net/p/ddclient/bugs/46/) + * Fallback to iproute if ifconfig doesn't work sent by Maccied Grela + +### Detailed list of changes + + * [r156] wimpunk: patches: Moving patching to the root of the repository. + + The patches are mostly there for historical reasons. They've been moved + away to make cleaning easier. I think the applied patches should even be + removed. + * [r155] wimpunk: ddclient: Fallback to iproute if ifconfig doesn't work. + + This fix applies the patch provided by Maccied Grela in [bugs:#26] + * [r154] wimpunk: ddclient: preventing deep sleep - see [bugs:#46] + + Fixing [bugs:#46] by applying the provided patch. + * [r153] wimpunk: ddclient: Applying patch from [fb1ad014] fixing bug [#14] + + More info can be found on [fb1ad014] and has been discussed in the + mailinglist: + http://article.gmane.org/gmane.network.dns.ddclient.user/71. The patch was + send by Rodrigo Araujo. + * [r152] wimpunk: ddclient: Adding sha1-patch provided by pirast in + [9742ac09] + * [r150] wimpunk: README.md, ddclient, sample-etc_ddclient.conf: Adding + support for ChangeIP based on the patch from Michele Giorato + http://sourceforge.net/p/ddclient/discussion/399428/thread/e85661ad/ + * [r148] wimpunk: README.md: Updated README file + * [r147] wimpunk: ., README, README.md: Applying markdown syntax to README + +## 2011-07-11 v3.8.1 + + * Fixed [SourceForge Trac ticket + #28](https://sourceforge.net/p/ddclient/tractickets/28/): + FreeDNS.afraid.org changed api slightly + * Added dtdns-support + * Added support for longer password + * Added cisco-asa patch + * Added support for LoopiaDNS + +### Detailed list of changes + + * [r131] wimpunk: release/readme.txt: Updates after releasing 3.8.1 + * [r129] wimpunk: release/readme.txt: Corrected release/readme.txt + * [r128] wimpunk: sample-etc_ppp_ip-up.local: Applied ip-up_run-parts.diff + from ubuntu + * [r127] wimpunk: ddclient: Applied smc-barricade-fw-alt.diff from ubuntu + * [r126] wimpunk: ddclient: Fixing #28: FreeDNS.afraid.org changed api + slightly + * [r125] wimpunk: ddclient, sample-etc_ddclient.conf: Added patch for + dtdns-support (#39) + * [r124] wimpunk: ddclient: Patching with nic_updateable-warning patch + provided by antespi in ticket #2 + * [r123] wimpunk: ddclient: Patching with zoneedit patch provided by + killer-jk in ticket #15 + * [r122] wimpunk: ddclient: Added longer password support, sended by Ingo + Schwarze (#3130634) + * [r121] wimpunk: ddclient: Fixing bug #13: multiple fetch-ip but introducing + a multiple ip bug + * [r120] wimpunk: ddclient: patch for #10: invalid value for keyword ip + * [r119] wimpunk: ddclient: Applied patch from ticket #8, patch for cache + content leaks to global + * [r118] wimpunk: ddclient: Applied patch from ticket #7, provided by Chris + Carr + * [r117] wimpunk: ddclient: Fixed #6: Add Red Hat package name to Perl module + IO::Socket::SSL error message + * [r116] wimpunk: ddclient: Subversion revision added + * [r115] wimpunk: ddclient, patches/cisco-asa.patch: Added cisco-asa patch + (2891001) submitted by Philip Gladstone + * [r114] wimpunk: ddclient, patches/prevent-hang.patch: Added prevent-hang + patch (2880462) submitted by Panos + * [r113] wimpunk: ddclient, patches/foreground.patch: Added foreground patch + (1893144) submitted by John Palkovic + * [r112] wimpunk: README, ddclient, patches/loopia.patch, + sample-etc_ddclient.conf: #1609799 Support for LoopiaDNS (submitted by + scilence) + * [r111] wimpunk: ddclient, patches/freedns-patch: applied freedns patch + (patch 2832129) + * [r110] wimpunk: ddclient: Bug 2792436: fixed abuse message of dyndns + * [r109] wimpunk: sample-etc_ddclient.conf: Added warning about the update + interval (#2619505) + * [r108] wimpunk: .cvsignore, RELEASENOTE, ddclient, release, + release/readme.txt: Modified during the release of ddclient-3.8.0 + +## 2009-01-27 v3.8.0 + +### Detailed list of changes + + * [r106] wimpunk: ddclient: help about postscript added + * [r105] wimpunk: ddclient, patches/password.patch: Added better password + handling sended by Ingo Schwarze + * [r104] wimpunk: TODO, sample-ddclient-wrapper.sh: Added ddclient wrapper + script + * [r103] wimpunk: ddclient: Extra fix for multiple IP's + * [r102] wimpunk: sample-etc_ddclient.conf: Added some remarks concerning the + postscript. See https://sourceforge.net/forum/message.php?msg_id=5550545 + * [r101] wimpunk: ddclient, patches/multiple-ip.patch: Added support for + multiple IP adresses. See + http://permalink.gmane.org/gmane.network.dns.ddclient.user/17 + * [r100] wimpunk: patches/namecheap.patch: extra comments added to namecheap + patch + * [r99] wimpunk: patches/namecheap.patch: namecheap patch added to patches + section + * [r98] wimpunk: .: New trunk created based on the old trunk/svn + * [r96] wimpunk: svn: Moved old trunk/svn to ddclient and it will be the new + trunk + * [r95] wimpunk: svn: Ignoring test configuration + * [r94] wimpunk: svn/.cvsignore, svn/RELEASENOTE, svn/UPGRADE: Added some + release related files + * [r93] wimpunk: svn/patches/no-host.patch: Added not used no-host patch to + patches section + * [r90] wimpunk: svn/ddclient: Added more info about the daemon interval + * [r89] wimpunk: svn/ddclient: Preventing error while reading cache when ip + wasn't set correctly before + * [r88] wimpunk: svn/ddclient: Preventing an error when trying to send a + message on mail-failure + * [r87] wimpunk: svn/ddclient, svn/sample-etc_ddclient.conf: Modified + documentation about zoneedit based on the comments from Oren Held + * [r86] wimpunk: svn/patches/ddclient.daemon-timeout.patch: Added patch which + was applied to rev 27 (posted by James deBoer) + * [r85] wimpunk: svn/patches/eurodns.patch: Patch modified to apply on + ddclient 3.7.3 + * [r84] wimpunk: svn/patches/mail-on-kill.patch: Added mail-on-kill patch to + patches section + * [r83] wimpunk: svn/ddclient: Sending mail when killed, not after + TERM-signal + * [r82] wimpunk: svn/README: Added creation of cache dir + * [r81] wimpunk: svn/ddclient, svn/patches/ubuntu/default-timeout.patch: + Added and applied default timeout patch from + https://bugs.launchpad.net/ubuntu/+source/ddclient/+bug/116066 + * [r80] wimpunk: svn/ddclient, svn/patches/ddclient-noip.patch: Added + ddclient-noip.patch send by Kurt Bussche. + +## 2007-08-07 v3.7.3 + + * Changelog moved to more correct ChangeLog generated by `svn2cl + --group-by-day -i`. See http://tinyurl.com/2fzhc6 + +### Detailed list of changes + + * [r78] wimpunk: svn/ddclient: Updated version number to 3.7.3 + * [r77] wimpunk: svn/ddclient, svn/patches/typo_dnspark.patch: Applied + typo_dnspark.patch send by Marco + * [r76] wimpunk: svn/README.ssl: Renamed dyndns.org to dyndns.com + * [r75] wimpunk: svn/README: Removed ^M at line 37 + * [r74] wimpunk: svn/ddclient: Removed line 183, comments on Vigor 2200 USB + * [r73] wimpunk: svn: Ignoring ChangeLog since autogenerated + * [r72] wimpunk: svn/Changelog: Notification about changed ChangeLog + configuration + * [r71] wimpunk: svn/patches/ubuntu/dyndns_com.diff: Removed patch since it's + invalid + * [r70] wimpunk: svn/patches/opendns.patch: Added not applied opendns.patch, + see tracker #1758564 + * [r69] wimpunk: svn/patches/debianpatches, + svn/patches/debianpatches/abuse_msg.diff, + svn/patches/debianpatches/cachedir.diff, + svn/patches/debianpatches/cisco_fw.diff, + svn/patches/debianpatches/config_path.diff, + svn/patches/debianpatches/daemon_check.diff, + svn/patches/debianpatches/daemon_interval.diff, + svn/patches/debianpatches/help_nonroot(2).diff, + svn/patches/debianpatches/help_nonroot.diff, + svn/patches/debianpatches/ip-up_run-parts.diff, + svn/patches/debianpatches/maxinterval.diff, + svn/patches/debianpatches/readme.txt, + svn/patches/debianpatches/sample_path.diff, + svn/patches/debianpatches/smc-barricade-7401bra.patch, + svn/patches/debianpatches/smc-barricade-fw-alt.diff, + svn/patches/debianpatches/update-new-config.patch, svn/patches/ubuntu, + svn/patches/ubuntu/checked_ssl_load.diff, + svn/patches/ubuntu/config_path.diff, + svn/patches/ubuntu/daemon_interval.diff, + svn/patches/ubuntu/dyndns_com.diff, svn/patches/ubuntu/sample_ubuntu.diff, + svn/patches/ubuntu/series, svn/patches/ubuntu/smc-barricade-fw-alt.diff: + Added debian and ubuntu patches + * [r68] wimpunk: svn/TODO: Added url to feature request dyndns + * [r67] wimpunk: svn/README, svn/patches/readme.patch: Run dos2unix on readme + and it's patch which Marco Rodrigues submitted. + * [r66] wimpunk: svn/README, svn/patches/readme.patch: Partial applied + readme.patch. See tracker #1752931 + * [r65] wimpunk: svn/ddclient: signature modified + * [r64] wimpunk: svn/ddclient: Added website to ddclient comments + * [r63] wimpunk: svn/patches/regex_vlan.patch: Added extra comments to the + patch. + * [r62] wimpunk: svn/ddclient, svn/patches/create_patch.sh, + svn/patches/regex_vlan.patch, svn/patches/typo_namecheap_patch.diff.new: + Added patches and applied regex_vlan.patch. See bug #1747337 + * [r61] wimpunk: svn/ddclient: Applied typo_namecheap_patch.diff send by + Marco Rodrigues + * [r60] wimpunk: svn/sample-etc_ppp_ip-up.local: Reverted the patch from + torsten. See [ 1749470 ] Bug in Script sample-etc_ppp_ip-up.local + * [r59] wimpunk: svn/release, svn/release/readme.txt: Adding some release + documentation + +## 2007-06-14 v3.7.2 + + * Preventing unitialized values, check + https://sourceforge.net/forum/message.php?msg_id=4167772 + * added a TODO list + * Removed the two empty lines at the end of ddclient + * Applied checked_ssl_load.diff from Ubuntu + * Cosmetic change about checkip + * Changed nic_namecheap_update following the suggestion of edmdude on the + forum (https://sourceforge.net/forum/message.php?msg_id=4316938) + * Applied easydns.patch + * 3com-oc-remote812 patch by The_Beast via IRC. + * Applied eurodns.patch + +### Detailed list of changes + + * [r57] wimpunk: svn/Changelog, svn/ddclient: Changed version number + * [r55] wimpunk: svn/patches, svn/patches/3com-oc-remote812.patch, + svn/patches/easydns.patch, svn/patches/eurodns.patch: Patches directory + added + * [r54] wimpunk: svn/ddclient: 3com-oc-remote812 patch by The_Beast via IRC: + see patches/3com-oc-remote812.patch + * [r53] wimpunk: svn/ddclient: Applied easydns.patch, patch 117054 + * [r52] wimpunk: svn/ddclient: Changed nic_namecheap_update following the + suggestion of edmdude on the forum + (https://sourceforge.net/forum/message.php?msg_id=4316938) + * [r48] wimpunk: svn/ddclient: Cosmetic change about checkip + * [r47] wimpunk: svn/ddclient: Applied checked_ssl_load.diff from ubuntu + * [r46] wimpunk: svn/ddclient: Removed the two empty lines at the end of + ddclient + * [r44] wimpunk: svn/TODO: added a TODO list + * [r43] wimpunk: svn/Changelog, svn/ddclient: Preventing unitialized values, + check https://sourceforge.net/forum/message.php?msg_id=4167772 + +## 2007-01-25 v3.7.1 + + * URL of zoneedit has changed (see bug #1558483) + * Added initscript for Ubuntu (posted by Paolo Martinelli) + * Added patch "Patch: Treat --daemon values as intervals" (submitted by James + deBoer) + * Don't send any mail when in not running daemon mode (patch submitted by + Daniel Thaler) + * Changed Changelog syntax + * Applied patches submitted by Torsten: + * abuse_msg.diff: ddclient still reports the email to contact dyndns.org + but they prefer a web form today (IIRC). This patch adjusts the abuse + warning printed by ddclient. + * cachedir.diff: Original ddclient stores a cache file in /etc which + would belong in /var/cache in my opinion and according to the FHS. + * help_nonroot.diff: Allow calling the help function as non-root. + * update-new-config.patch: Force update if config has changed + * smc-barricade-7401bra.patch: Support for SMC Barricade 7401BRA FW + firewall + * cisco_fw.diff: Use configured hostname for firewall access with + -use=cisco (closes: #345712). Thanks to Per Carlson for the patch! See + http://bugs.debian.org/345712. + * maxinterval.diff: Increase max interval for updates. See + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=129370 + http://www.dyndns.com/support/services/dyndns/faq.html#q15 + * Changed max-interval to 25days. See + https://www.dyndns.com/services/dns/dyndns/faq.html + +### Detailed list of changes + + * [r40] wimpunk: svn/Changelog, svn/ddclient: Changed max-interval to + 25days. See https://www.dyndns.com/services/dns/dyndns/faq.html + * [r39] wimpunk: svn/Changelog, svn/ddclient: Applied maxinterval.diff: + Increase max interval for updates. See + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=129370 + http://www.dyndns.com/support/services/dyndns/faq.html#q15 + * [r38] wimpunk: svn/ddclient: Applied cisco_fw.diff: Use configured hostname + for firewall access with -use=cisco (closes: #345712). Thanks to Per + Carlson for the patch! See http://bugs.debian.org/345712. + * [r37] wimpunk: svn/Changelog, svn/ddclient: Applied + smc-barricade-7401bra.patch: Support for SMC Barricade 7401BRA FW firewall + (submitted by Torsten) Changelog modified for all previous patches from + Torsten + * [r36] wimpunk: svn/ddclient: Applied update-new-config.patch: Force update + if config has changed (submitted by Torsten) + * [r35] wimpunk: svn/sample-etc_ppp_ip-up.local: Applied + ip-up_run-parts.diff: Fix parameter in ip-up script. (submitted by + Torsten) + * [r34] wimpunk: svn/ddclient: Applied help_nonroot.diff: Allow calling the + help function as non-root. (submitted by Torsten) + * [r33] wimpunk: svn/ddclient: Applied cachedir.diff: Original ddclient + stores a cache file in /etc which would belong in /var/cache in my opinion + and according to the FHS. Patch changes that. (submitted by Torsten) + * [r32] wimpunk: svn/ddclient: Applied abuse_msg.diff: ddclient still reports + the email to contact dyndns.org but they prefer a web form today + (IIRC). This patch adjusts the abuse warning printed by + ddclient. (submitted by Torsten) + * [r31] wimpunk: svn/Changelog: Changed Changelog syntax + * [r30] wimpunk: svn/Changelog, svn/ddclient: Don't send any mail when in not + running daemon mode (patch submitted by Daniel Thaler) + * [r28] wimpunk: svn/Changelog, svn/ddclient: Added patch "Patch: Treat + --daemon values as intervals" (submitted by James deBoer) + * [r22] wimpunk: svn/Changelog, svn/sample-etc_rc.d_init.d_ddclient.ubuntu: + Added initscript for Ubuntu (posted by Paolo Martinelli) + * [r21] wimpunk: svn/Changelog, svn/ddclient: URL of zoneedit has changed + (see bug #1558483) + +## 2006-06-14 v3.7.0 + + * Added vi tag + * Added support for 2Wire 1701HG Gateway (see + https://sourceforge.net/forum/message.php?msg_id=3496041 submitted by hemo) + * added ssl-support by perlhaq + * updated cvs version to 3.7.0-pre + * added support for Linksys RV042, see feature requests #1501093, #1500877 + * added support for netgear-rp614, see feature request #1237039 + * added support for watchguard-edge-x, patch #1468981 + * added support for dlink-524, see patch #1314272 + * added support for rtp300 + * added support for netgear-wpn824 + * added support for linksys-wcg200, see patch #1280713 + * added support for netgear-dg834g, see patch #1176425 + * added support for netgear-wgt624, see patch #1165209 + * added support for sveasoft, see patch #1102432 + * added support for smc-barricade-7004vbr, see patch #1087989 + * added support for sitecom-dc202, see patch #1060119 + * fixed the error of stripping out '#' in the middle of password, bug + #1465932 + * fixed a couple bugs in sample-etc_rc.d_init.d_ddclient and added some extra + auto distro detection + * added the validation of values when reading the configuration value. + * this fixes a bug when trying to use periods/intervals in the daemon check + times, bug #1209743 + * added timeout option to the IO::Socket call for timing out the initial + connection, bug: #1085110 + +### Detailed list of changes + + * [r11] wimpunk: svn/Changelog, svn/ddclient: Changed version number + * [r8] wimpunk: ., html, svn, xml: Created trunk and tags, moved directories + to it + * [r6] wimpunk: Changed the order of perl and update of README.ssl + * [r5] ddfisher: see Changelog + * [r4] ddfisher: updated changelog + * [r3] ddfisher: See Changelog + * [r2] wimpunk: Reorganise + +## v3.6.7 + + * modified sample-etc_rc.d_init.d_ddclient.lsb (bug #1231930) + * support for ConCont Protocol (patch #1265128) submitted by seather_misery + * problem with sending mail should be solved + * corrected a few writing mistakes + * support for 'NetComm NB3' adsl modem (submitted by crazyprog) + * Added Sitelutions DynDNS, fixed minor Namecheap bug (patch #1346867) + +## v3.6.6 + + * support for olitec-SX200 + * added sample-etc_rc.d_init.d_ddclient.lsb as a sample script for + lsb-compliant systems. + * support for linksys wrt854g (thanks to Nick Triantos) + * support for linksys ver 3 + * support for Thomson (Alcatel) SpeedTouch 510 (thanks to Aldoir) + * Cosmetic fixes submitted by John Owens + +## v3.6.5 + + * there was a bug in the linksys-ver2 + * support for postscript (thanks to Larry Hendrickson) + * Changelog out of README + * modified all documentation to use /etc/ddclient/ddclient.conf (notified by + nicolasmartin in bug [1070646]) + +## v3.6.4 + + * added support for NameCheap service (thanks to Dan Boardman) + * added support for linksys ver2 (thanks to Dan Perik) + +## v3.6.3 + + * renamed sample-etc_dhclient-enter-hooks to sample-etc_dhclient-exit-hooks + * add support for the Allnet 1298 Router + * add -a to ifconfig to query all interfaces (for Solaris and OpenBSD) + * update the process status to reflect what is happening. + * add a To: line when sending e-mail + * add mail-failure to send mail on failures only + * try all addresses for multihomed hosts (like check.dyndns.org) + * add support for dnspark + * add sample for OrgDNS.org + +## v3.6.2 + + * add support for Xsense Aero + * add support for Alcatel Speedtouch Pro + * do authentication when either the login or password are defined. + * fix parsing of web status pages + +## v3.6 + + * add support for EasyDNS (see easydns.com) + * add warning for possible incorrect continuation lines in the .conf file. + * add if-skip with the default as was used before. + * add cmd-skip. + +## v3.5.4 + + * added !active result code for DynDNS.org + +## v3.5.2 + + * avoid undefined variable in get_ip + +## v3.5.1 + + * fix parsing of quoted strings in .conf file + * add filename and line number to any warnings regarding files. + +## v3.5 + + * allow any url to be specified for -fw {address|url}. use -fw-skip + {pattern} to specify a string preceding the IP address at the URL's page + * allow any url to be specified for -web {address|url}. use -web-skip + {pattern} to specify a string preceding the IP address at the URL's page + * modify -test to display any IP addresses that could be obtained from any + interfaces, builtin fw definitions, or web status pages. + +## v3.4.6 (not released) + + * fix errors in -help + * allow non-FQDNs as hosts; dslreports requires this. + * handle german ifconfig output + * try to get english messages from ifconfig so other languages are handled + too. + * added support for com 3c886a 56k Lan Modem + +## v3.4.5 + + * handle french ifconfig output + +## v3.4.4 + + * added support for obtaining the IP address from a Cisco DHCP interface. + (Thanks, Tim) + +## v3.4.2 + + * update last modified time when nochg is returned from dyndns + * add example regarding fw-login and fw-password's required by some home + routers + +## v3.4.1 + + * add option (-pid) to record process id in a file. This option should be + defined in the .conf file as it is done in the sample. + * add detection of SIGHUP. When this signal is received, ddclient will wake + up immediately, reload it's configuration file, and update the IP addresses + if necessary. + +## v3.4 + + * ALL PEOPLE USING THIS CLIENT ARE URGED TO UPGRADE TO 3.4 or better. + * fixed several timer related bugs. + * reformatted some messages. + +## v3.3.8 + + * added support for the ISDN channels on ELSA LANCOM DSL/10 router + +## v3.3.7 + + * suppress repeated identical e-mail messages. + +## v3.3.6 + + * added support for the ELSA LANCOM DSL/10 router + * ignore 0.0.0.0 when obtained from any FW/router. + +## v3.3.5 + + * fixed sample ddclient.conf. fw-ip= should be fw= + * fixed problem getting status pages for some routers + +## v3.3.4 + + * added support for the MaxGate's UGATE-3x00 routers + +## v3.3.3 + + * sample* correct checks for private addresses + * add redhat specific sample-etc_rc.d_init.d_ddclient.redhat + * make daemon-mode be the default when named ddclientd + * added support for the Linksys BEF* Internet Routers + +## v3.3.2 + + * (sample-etc_rc.d_init.d_ddclient) set COLUMNS to a large number so that 'ps + -aef' will not prematurely truncate the CMD. + +## v3.3 + + * added rpm (thanks to Bo Forslund) + * added support for the Netgear RT3xx Internet Routers + * modified sample-etc_rc.d_init.d_ddclient to work with other Unix beside + RedHat. + * avoid rewritting the ddclient.cache file unnecessarily + * fixed other minor bugs + +## v3.2.0 + + * add support for DynDNS's custom domain service. + * change suggested directory to /usr/sbin + +## v3.1.0 + + * clean up; fix minor bugs. + * removed -refresh + * add min-interval to avoid too frequent update attempts. + * add min-error-interval to avoid too frequent update attempts when the + service is unavailable. + +## v3.0.1 + + * make all values case sensitive (ie. passwords) + +## v3.0 + + * new release! + * new ddclient.conf format + * rewritten to support DynDNS's NIC2 and other dynamic DNS services + * added Hammernode (hn.org) + * added ZoneEdit (zoneedit.com) + * added DSLreports (dslreports.com) host monitoring + * added support for obtaining IP addresses from interfaces, commands, web, + external commands, Watchguard's SOHO router Netopia's R910 router and SMC's + Barracade + * added daemon mode + * added logging msgs to syslog and e-mail + +## v2.3.7 + + * add -refresh to the sample scripts so default arguments are obtained from + the cache + * added local-ip script for obtaining the address of an interface + * added public-ip script for obtaining the ip address as seen from a public + web page + +## v2.3.6 + + * fixed bug the broke enabling retrying when members.dyndns.org was down. + +## v2.3.5 + + * prevent warnings from earlier versions of Perl. + +## v2.3.4 + + * added sample-etc_dhclient-enter-hooks for those using the ISC DHCP client + (dhclient) + +## v2.3.3 + + * make sure that ddclient.conf is only readable by the owner so that no one + else can see the password (courtesy of Steve Greenland). NOTE: you will + need to change the permissions on ddclient.conf to prevent others from + obtaining viewing your password. ie. chmod go-rwx /etc/ddclient.conf + +## v2.3.2 + + * make sure 'quiet' messages are printed when -verbose or -debug is enabled + * fix error messages for those people using proxies. + +## v2.3 + + * fixed a problem reading in cached entries + + +## v2.2.1 + + * sample-etc_ppp_ip-up.local - local ip address is $4 or $PPP_LOCAL (for + debian) + * use as the line terminator (some proxies are strict about this) + +## v2.2 + + * added support (-static) for updating static DNS (thanks Marc Sira) + * changed ddclient.cache format (old style is still read) + * sample-etc_ppp_ip-up.local - detect improper calling sequences + * sample-etc_ppp_ip-up.local - local ip address is $3 or $PPP_LOCAL (for + debian) + +## v2.1.2 + + * updated README + +## v2.1.1 + + * make sure result code reflects any failures + * optionally (-quiet) omit messages for unnecessary updates + * update sample-etc_cron.d_ddclient to use -quiet + +## v2.1 + + * avoid unnecessary updates by recording the last hosts updated in a cache + file (default /etc/ddclient.cache) + * optionally (-force) force an update, even if it may be unnecessary. + + This can be used to prevent dyndns.org from deleting a host that has not + required an update for a long period of time. + * optionally (-refresh), reissue all host updates. + + This can be used together with cron to periodically update DynDNS. See + sample-etc-cron.d-ddclient for details. + * optionally (-retry) save failed updates for future processing. + + This feature can be used to reissue updates that may have failed due to + network connectivity problems or a DynDNS server outage diff -Nru ddclient-3.9.1/Changelog.old ddclient-3.10.0/Changelog.old --- ddclient-3.9.1/Changelog.old 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/Changelog.old 1970-01-01 00:00:00.000000000 +0000 @@ -1,302 +0,0 @@ -Changelog -3.7.3 - * Changelog moved to more correct ChangeLog - generated by svn2cl --group-by-day -i - See http://tinyurl.com/2fzhc6 - -3.7.2 - * Preventing unitialized values, check - https://sourceforge.net/forum/message.php?msg_id=4167772 - * added a TODO list - * Removed the two empty lines at the end of ddclient - * Applied checked_ssl_load.diff from Ubuntu - * Cosmetic change about checkip - * Changed nic_namecheap_update following the suggestion of edmdude - on the forum (https://sourceforge.net/forum/message.php?msg_id=4316938) - * Applied easydns.patch - * 3com-oc-remote812 patch by The_Beast via IRC. - * Applied eurodns.patch - -3.7.1 - * URL of zoneedit has changed (see bug #1558483) - * Added initscript for Ubuntu (posted by Paolo Martinelli) - * Added patch "Patch: Treat --daemon values as intervals" - (submitted by James deBoer) - * Don't send any mail when in not running daemon mode - (patch submitted by Daniel Thaler) - * Changed Changelog syntax - * Applied patches submitted by Torsten: - abuse_msg.diff: ddclient still reports the email to contact dyndns.org - but they prefer a web form today (IIRC). This patch adjusts the abuse - warning printed by ddclient. - cachedir.diff: Original ddclient stores a cache file in /etc which - would belong in /var/cache in my opinion and according to the FHS. - help_nonroot.diff: Allow calling the help function as non-root. - update-new-config.patch: Force update if config has changed - smc-barricade-7401bra.patch: Support for SMC Barricade 7401BRA FW - firewall - cisco_fw.diff: Use configured hostname for firewall access - with -use=cisco (closes: #345712). Thanks to Per Carlson for the - patch! See http://bugs.debian.org/345712. - maxinterval.diff: Increase max interval for updates. - See http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=129370 - http://www.dyndns.com/support/services/dyndns/faq.html#q15 - * Changed max-interval to 25days. See - https://www.dyndns.com/services/dns/dyndns/faq.html - - -3.7.0 -- Added vi tag -- Added support for 2Wire 1701HG Gateway (see - https://sourceforge.net/forum/message.php?msg_id=3496041 submitted by hemo) -- added ssl-support by perlhaq -- updated cvs version to 3.7.0-pre -- added support for Linksys RV042, see feature requests #1501093, #1500877 -- added support for netgear-rp614, see feature request #1237039 -- added support for watchguard-edge-x, patch #1468981 -- added support for dlink-524, see patch #1314272 -- added support for rtp300 -- added support for netgear-wpn824 -- added support for linksys-wcg200, see patch #1280713 -- added support for netgear-dg834g, see patch #1176425 -- added support for netgear-wgt624, see patch #1165209 -- added support for sveasoft, see patch #1102432 -- added support for smc-barricade-7004vbr, see patch #1087989 -- added support for sitecom-dc202, see patch #1060119 -- fixed the error of stripping out '#' in the middle of password, bug #1465932 -- fixed a couple bugs in sample-etc_rc.d_init.d_ddclient and added some extra auto distro detection -- added the validation of values when reading the configuration value. -- this fixes a bug when trying to use periods/intervals in the daemon check times, bug #1209743 -- added timeout option to the IO::Socket call for timing out the initial connection, bug: #1085110 - -3.6.7 -- modified sample-etc_rc.d_init.d_ddclient.lsb (bug #1231930) -- support for ConCont Protocol (patch #1265128) submitted by seather_misery -- problem with sending mail should be solved -- corrected a few writing mistakes -- support for 'NetComm NB3' adsl modem (submitted by crazyprog) -- Added Sitelutions DynDNS, fixed minor Namecheap bug (patch #1346867) - -3.6.6 -- support for olitec-SX200 -- added sample-etc_rc.d_init.d_ddclient.lsb as a sample script for lsb-compliant systems. -- support for linksys wrt854g (thanks to Nick Triantos) -- support for linksys ver 3 -- support for Thomson (Alcatel) SpeedTouch 510 (thanks to Aldoir) -- Cosmetic fixes submitted by John Owens - -3.6.5 -- there was a bug in the linksys-ver2 -- support for postscript (thanks to Larry Hendrickson) -- Changelog out of README -- modified all documentation to use /etc/ddclient/ddclient.conf (notified by nicolasmartin in bug [1070646]) - -3.6.4 -- added support for NameCheap service (thanks to Dan Boardman) -- added support for linksys ver2 (thanks to Dan Perik) - -3.6.3 -- renamed sample-etc_dhclient-enter-hooks to sample-etc_dhclient-exit-hooks -- add support for the Allnet 1298 Router -- add -a to ifconfig to query all interfaces (for Solaris and OpenBSD) -- update the process status to reflect what is happening. -- add a To: line when sending e-mail -- add mail-failure to send mail on failures only -- try all addresses for multihomed hosts (like check.dyndns.org) -- add support for dnspark -- add sample for OrgDNS.org - -3.6.2 -- add support for Xsense Aero -- add support for Alcatel Speedtouch Pro -- do authentication when either the login or password are defined. -- fix parsing of web status pages - -- 3.6 -- add support for EasyDNS (see easydns.com) -- add warning for possible incorrect continuation lines in the .conf file. -- add if-skip with the default as was used before. -- add cmd-skip. - -- 3.5.4 -- added !active result code for DynDNS.org - -- 3.5.2 -- avoid undefined variable in get_ip - -- 3.5.1 -- fix parsing of quoted strings in .conf file -- add filename and line number to any warnings regarding files. - -- 3.5 -- allow any url to be specified for -fw {address|url} - use -fw-skip {pattern} to specify a string preceding the IP address at the URL's page -- allow any url to be specified for -web {address|url} - use -web-skip {pattern} to specify a string preceding the IP address at the URL's page -- modify -test to display any IP addresses that could be obtained from - any interfaces, builtin fw definitions, or web status pages. - -- 3.4.6 (not released) -- fix errors in -help -- allow non-FQDNs as hosts; dslreports requires this. -- handle german ifconfig output -- try to get english messages from ifconfig so other languages are handled too. -- added support for com 3c886a 56k Lan Modem - -- 3.4.5 -- handle french ifconfig output - -- 3.4.4 -- added support for obtaining the IP address from a Cisco DHCP interface. - (Thanks, Tim) - -- 3.4.2 -- update last modified time when nochg is returned from dyndns -- add example regarding fw-login and fw-password's required by some - home routers - -- 3.4.1 -- add option (-pid) to record process id in a file. This option should be - defined in the .conf file as it is done in the sample. -- add detection of SIGHUP. When this signal is received, ddclient will - wake up immediately, reload it's configuration file, and update - the IP addresses if necessary. - -- 3.4 -- ALL PEOPLE USING THIS CLIENT ARE URGED TO UPGRADE TO 3.4 or better. -- fixed several timer related bugs. -- reformatted some messages. - -- 3.3.8 -- added support for the ISDN channels on ELSA LANCOM DSL/10 router - -- 3.3.7 -- suppress repeated identical e-mail messages. - -- 3.3.6 -- added support for the ELSA LANCOM DSL/10 router -- ignore 0.0.0.0 when obtained from any FW/router. - -- 3.3.5 -- fixed sample ddclient.conf. fw-ip= should be fw= -- fixed problem getting status pages for some routers - -- 3.3.4 -- added support for the MaxGate's UGATE-3x00 routers - -- 3.3.3 -- sample* correct checks for private addresses -- add redhat specific sample-etc_rc.d_init.d_ddclient.redhat -- make daemon-mode be the default when named ddclientd -- added support for the Linksys BEF* Internet Routers - -- 3.3.2 -- (sample-etc_rc.d_init.d_ddclient) set COLUMNS to a large number so that - 'ps -aef' will not prematurely truncate the CMD. - -- 3.3 -- added rpm (thanks to Bo Forslund) -- added support for the Netgear RT3xx Internet Routers -- modified sample-etc_rc.d_init.d_ddclient to work with other Unix beside RedHat. -- avoid rewritting the ddclient.cache file unnecessarily -- fixed other minor bugs - -- 3.2.0 -- add support for DynDNS's custom domain service. -- change suggested directory to /usr/sbin - -- 3.1.0 -- clean up; fix minor bugs. -- removed -refresh -- add min-interval to avoid too frequent update attempts. -- add min-error-interval to avoid too frequent update attempts when the - service is unavailable. - -- 3.0.1 -- make all values case sensitive (ie. passwords) - -- 3.0 -- new release! -- new ddclient.conf format -- rewritten to support DynDNS's NIC2 and other dynamic DNS services -- added Hammernode (hn.org) -- added ZoneEdit (zoneedit.com) -- added DSLreports (dslreports.com) host monitoring -- added support for obtaining IP addresses from -- interfaces, -- commands, -- web, -- external commands, -- Watchguard's SOHO router -- Netopia's R910 router -- and SMC's Barracade -- added daemon mode -- added logging msgs to syslog and e-mail - -- 2.3.7 -- add -refresh to the sample scripts so default arguments are obtained from the cache -- added local-ip script for obtaining the address of an interface -- added public-ip script for obtaining the ip address as seen from a public web page - -- 2.3.6 -- fixed bug the broke enabling retrying when members.dyndns.org was down. - -- 2.3.5 -- prevent warnings from earlier versions of Perl. - -- 2.3.4 -- added sample-etc_dhclient-enter-hooks for those using the ISC DHCP client (dhclient) - -- 2.3.3 -- make sure that ddclient.conf is only readable by the owner so that no one -- else can see the password (courtesy of Steve Greenland). --- NOTE: you will need to change the permissions on ddclient.conf to prevent --- others from obtaining viewing your password. --- ie. chmod go-rwx /etc/ddclient.conf - -- 2.3.2 -- make sure 'quiet' messages are printed when -verbose or -debug is enabled -- fix error messages for those people using proxies. - -- 2.3 -- fixed a problem reading in cached entries - - -- 2.2.1 -- sample-etc_ppp_ip-up.local - local ip address is $4 or $PPP_LOCAL (for debian) -- use as the line terminator (some proxies are strict about this) - -- 2.2 -- added support (-static) for updating static DNS (thanks Marc Sira) -- changed ddclient.cache format (old style is still read) -- sample-etc_ppp_ip-up.local - detect improper calling sequences -- sample-etc_ppp_ip-up.local - local ip address is $3 or $PPP_LOCAL (for debian) - -- 2.1.2 -- updated README - -- 2.1.1 -- make sure result code reflects any failures -- optionally (-quiet) omit messages for unnecessary updates -- update sample-etc_cron.d_ddclient to use -quiet - -- 2.1 -- avoid unnecessary updates by recording the last hosts updated in a - cache file (default /etc/ddclient.cache) - -- optionally (-force) force an update, even if it may be unnecessary. - - This can be used to prevent dyndns.org from deleting a host that has not - required an update for a long period of time. - -- optionally (-refresh), reissue all host updates. - - This can be used together with cron to periodically update DynDNS. - See sample-etc-cron.d-ddclient for details. - -- optionally (-retry) save failed updates for future processing. - - This feature can be used to reissue updates that may have failed due to - network connectivity problems or a DynDNS server outage - ------------------------------------------------------------------------- diff -Nru ddclient-3.9.1/configure.ac ddclient-3.10.0/configure.ac --- ddclient-3.9.1/configure.ac 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/configure.ac 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,91 @@ +AC_PREREQ([2.63]) +AC_INIT([ddclient], [3.10.0_2]) +AC_CONFIG_SRCDIR([ddclient.in]) +AC_CONFIG_AUX_DIR([build-aux]) +AC_CONFIG_MACRO_DIR([m4]) +AC_REQUIRE_AUX_FILE([tap-driver.sh]) +# If the automake dependency is bumped to v1.12 or newer, remove +# build-aux/tap-driver.sh from the repository. Automake 1.12+ comes +# with tap-driver.sh, and autoreconf will copy in the version +# distributed with automake. (Automake 1.11 and older don't come with +# tap-driver.sh, so build-aux/tap-driver.sh is checked in to keep the +# above AC_REQUIRE_AUX_FILE line from causing configure to complain +# about a mising file if the user has Automake 1.11.) +AM_INIT_AUTOMAKE([1.11 -Wall -Werror foreign subdir-objects parallel-tests]) +AM_SILENT_RULES + +AC_PROG_MKDIR_P + +# The Fedora Docker image doesn't come with the 'findutils' package. +# 'find' is required for 'make distcheck', which the user might not +# run. We could log a warning instead of erroring out, but: +# * a warning is unlikely to be seen, +# * 'make distcheck' doesn't yield a non-0 exit code if 'find' is +# not available, +# * 'find' is a core utility that should always be available, and +# * we might use 'find' for other purposes in the future. +AC_PATH_PROG([FIND], [find]) +AS_IF([test -z "${FIND}"], [AC_MSG_ERROR(['find' utility not found])]) + +AC_PATH_PROG([CURL], [curl]) + +AX_WITH_PROG([PERL], perl) +AX_PROG_PERL_VERSION([5.10.1], [], + [AC_MSG_ERROR([Perl 5.10.1 or newer not found])]) +AC_SUBST([PERL]) + +# Perl modules required to run ddclient. Note: CentOS, RHEL, and +# Fedora put some core modules in separate packages, and the perl +# package doesn't depend on all of them, so their availability can't +# be assumed. +m4_foreach_w([_m], [ + File::Basename + File::Path + File::Temp + Getopt::Long + IO::Socket::INET + Socket + Sys::Hostname + version=0.77 + ], [AX_PROG_PERL_MODULES([_m], [], + [AC_MSG_ERROR([missing required Perl module _m])])]) + +# Perl modules required for tests. If these modules are not installed +# then some tests will fail. Only prints a warning if not installed. +m4_foreach_w([_m], [ + B + Data::Dumper + File::Spec::Functions + File::Temp + ], [AX_PROG_PERL_MODULES([_m], [], + [AC_MSG_WARN([some tests will fail due to missing module _m])])]) + +# Optional Perl modules for tests. If these modules are not installed +# then some tests will be skipped, but no tests should fail. Only +# prints a warning if not installed. +m4_foreach_w([_m], [ + Carp + Exporter + HTTP::Daemon=6.12 + HTTP::Daemon::SSL + HTTP::Message::PSGI + HTTP::Request + HTTP::Response + IO::Socket::INET6 + IO::Socket::IP + IO::Socket::SSL + Scalar::Util + Test::MockModule + Test::TCP + Test::Warnings + Time::HiRes + URI + ], [AX_PROG_PERL_MODULES([_m], [], + [AC_MSG_WARN([some tests may be skipped due to missing module _m])])]) + +AC_CONFIG_FILES([ + Makefile + t/geturl_connectivity.pl + t/version.pl + ]) +AC_OUTPUT diff -Nru ddclient-3.9.1/CONTRIBUTING.md ddclient-3.10.0/CONTRIBUTING.md --- ddclient-3.9.1/CONTRIBUTING.md 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/CONTRIBUTING.md 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,294 @@ +# How to Contribute + +Thank you for your interest in making ddclient better! This document +provides guidelines to make the contribution process as smooth as +possible. + +To contribute changes, please open a pull request against the +[ddclient GitHub project](https://github.com/ddclient/ddclient/pulls). + +## Developer Certificate of Origin + +All contributions are subject to the [Developer Certificate of Origin +v1.1](https://developercertificate.org/), copied below. A +`Signed-off-by` line in each commit message is **not** required. + +``` +Developer Certificate of Origin +Version 1.1 + +Copyright (C) 2004, 2006 The Linux Foundation and its contributors. +1 Letterman Drive +Suite D4700 +San Francisco, CA, 94129 + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. + + +Developer's Certificate of Origin 1.1 + +By making a contribution to this project, I certify that: + +(a) The contribution was created in whole or in part by me and I + have the right to submit it under the open source license + indicated in the file; or + +(b) The contribution is based upon previous work that, to the best + of my knowledge, is covered under an appropriate open source + license and I have the right under that license to submit that + work with modifications, whether created in whole or in part + by me, under the same open source license (unless I am + permitted to submit under a different license), as indicated + in the file; or + +(c) The contribution was provided directly to me by some other + person who certified (a), (b) or (c) and I have not modified + it. + +(d) I understand and agree that this project and the contribution + are public and that a record of the contribution (including all + personal information I submit with it, including my sign-off) is + maintained indefinitely and may be redistributed consistent with + this project or the open source license(s) involved. +``` + +## Style + + * Above all else, try to match the existing style surrounding your + edits. + * No trailing whitespace. + * Use spaces, not tabs. + * Indentation level is 4 spaces. + * Use parentheses for Perl function invocations: `print($fh "foo")` + not `print $fh "foo"` + * When reasonable, break lines longer than 99 characters. Rationale: + - Imposing a limit makes it practical to open many side-by-side + files or terminals without worrying about horizontal scrolling. + - 99 is used instead of 100 so that the +/- column added by + unified diff does not cause wrapping in 100 column wide + terminals. + * Add spaces to vertically align adjacent lines of code when doing + so improves readability. + +The following [perltidy](https://metacpan.org/pod/perltidy) command is +not perfect but it can get you close to our preferred style: + +```shell +perltidy -l=99 -conv -ci=4 -ola -ce -nbbc -kis -pt=2 -b ddclient +``` + +## Git Hygiene + + * Please keep your pull request commits rebased on top of master. + * Please use `git rebase -i` to make your commits easy to review: + - Put unrelated changes in separate commits + - Squash your fixup commits + * Write your commit message in imperative mood, and explain *why* + the change is made (unless obvious) in addition to *what* is + changed. + +If you are not very comfortable with Git, we encourage you to read +[Pro Git](https://git-scm.com/book) by Scott Chacon and Ben Straub +(freely available online). + +## Unit tests + +Always add tests for your changes when feasible. + +To run the ddclient test suite: + + 1. Install GNU Autoconf and Automake + 2. Run: `./autogen && ./configure && make VERBOSE=1 check` + +To add a new test script: + + 1. Create a new `t/*.pl` file with contents like this: + + ```perl + use Test::More; + # Your test dependencies go here. + + SKIP: { eval { require Test::Warnings; } or skip($@, 1); } + eval { require 'ddclient'; } or BAIL_OUT($@); + + # Your tests go here. + + done_testing(); + ``` + + See the documentation for + [Test::More](https://perldoc.perl.org/Test/More.html) for + details. + + 2. Add your script to the `handwritten_tests` variable in + `Makefile.am`. + + 3. If your test script requires 3rd party modules, add the modules + to the list of test modules in `configure.ac` and re-run + `./autogen && ./configure`. Be sure to skip the tests if the + module is not available. For example: + + ```perl + eval { require Foo::Bar; } or plan(skip_all => $@); + ``` + +## Compatibility + +We strive to find the right balance between features, code +maintainability, and broad platform support. To that end, please limit +yourself to Perl language features and modules available on the +following platforms: + + * Debian oldstable and newer + * Ubuntu, [all maintained + releases](https://ubuntu.com/about/release-cycle) + * Fedora, [all maintained + releases](https://fedoraproject.org/wiki/Fedora_Release_Life_Cycle) + * CentOS, [all maintained + releases](https://wiki.centos.org/About/Product) + * Red Hat Enterprise Linux, [all maintained + releases](https://access.redhat.com/support/policy/updates/errata/) + +See https://pkgs.org for available modules and versions. + +Exceptions: + * You may depend on modern language features or modules for new + functionality when no feasible alternative exists, as long as the + new dependency does not break existing functionality on old + plaforms. + * Test scripts may depend on arbitrary modules as long as the tests + are skipped if the modules are not available. Effort should be + taken to only use modules that are broadly available. + +You may use any core Perl module as long as it is available in all +versions of Perl we support. (Though please make sure it is listed in +the appropriate `configure.ac` check.) Stated another way: We are not +interested in supporting platforms that lack some core Perl modules, +unless doing so is trivial. + +All shell scripts should conform with [POSIX Issue 7 (2018 +edition)](https://pubs.opengroup.org/onlinepubs/9699919799/) or later. + +## Prefer Revert and Redo, Not Fix + +Suppose a recent change broke something or otherwise needs +refinement. It is tempting to simply push a fix, but it is usually +better to revert the original change then redo it: + + * There is less subjectivity with a revert, so you are more likely + to get a quick approval and merge. You can quickly "stop the + bleeding" while you and the project maintainers debate about the + best way to fix the problem with the original commit. + * It is easier and less mistake-prone to cherry-pick a single commit + (the redo commit) than two commits (the original commit plus the + required fix). + * Someone using blame to review the history will see the redo + commit, not the buggy original commit. + +## For ddclient Project Maintainers + +### Merging Pull Requests + +To facilitate reviews and code archaeology, `master` should have a +semi-linear commit history like this: + +``` +* f4e6e90 sandro.jaeckel@gmail.com 2020-05-31 07:29:51 +0200 (master) +|\ Merge pull request #142 from rhansen/config-line-format +| * 30180ed rhansen@rhansen.org 2020-05-30 13:09:38 -0400 +|/ Expand comment documenting config line format +* 01a746c rhansen@rhansen.org 2020-05-30 23:47:54 -0400 +|\ Merge pull request #138 from rhansen/dyndns-za-net +| * 08c2b6c rhansen@rhansen.org 2020-05-29 14:44:57 -0400 +|/ Replace dydns.za.net with dyndns.za.net +* d65805b rhansen@rhansen.org 2020-05-30 22:30:04 -0400 +|\ Merge pull request #140 from ddclient/fix-interpolation +| * babbef1 sandro.jaeckel@gmail.com 2020-05-30 04:03:44 +0200 +|/ Fix here doc interpolation +* 6ae69a1 rhansen@rhansen.org 2020-05-30 22:23:57 -0400 +|\ Merge pull request #141 from ddclient/show-debug-ssl +| * 096288e sandro.jaeckel@gmail.com 2020-05-30 04:42:27 +0200 +| | Expand tabs to spaces in vim +| * 0206262 sandro.jaeckel@gmail.com 2020-05-30 04:40:58 +0200 +|/ Show debug connection settings after evaluating use-ssl +... +``` + +See https://stackoverflow.com/a/15721436 for an explanation of the +benefits. + +This semi-linear style is mostly useful for multi-commit pull +requests. For single-commit pull requests, GitHub's "Squash and merge" +and "Rebase and merge" options are fine, though this approach still +has value: + + * The merge commit's commit message can link to the pull request + or contain other contextual information. + * It's easier to see who merged the PR (just look at the merge + commit author.) + * You can easily see both the original author timestamp (when the + change was made) and the merge timestamp (when it went live). + +To achieve a history like the above, the pull request must be rebased +onto `master` before merging. Unfortunately, GitHub does not have a +one-click way to do this (the "Rebase and merge" option does a +fast-forward merge, which is not what we want). See +[isaacs/github#1143](https://github.com/isaacs/github/issues/1143) and +[isaacs/github#1017](https://github.com/isaacs/github/issues/1017). Until +GitHub adds that feature, it has to be done manually: + +```shell +# Set this to the name of the GitHub user or project that owns the +# fork used for the pull request: +PR_USER= + +# Set this to the name of the branch in the fork used for the pull +# request: +PR_BRANCH= + +# The commands below assume that `origin` refers to the +# ddclient/ddclient repository +git remote set-url origin git@github.com:ddclient/ddclient.git + +# Add a remote for the fork used in the PR +git remote add "${PR_USER:?}" git@github.com:"${PR_USER:?}"/ddclient + +# Fetch the latest commits for the PR and ddclient master +git remote update -p + +# Switch to the pull request branch +git checkout -b "${PR_USER:?}-${PR_BRANCH:?}" "${PR_USER:?}/${PR_BRANCH:?}" + +# Rebase the commits (optionally using -i to clean up history) onto +# the current ddclient master branch +git rebase origin/master + +# Force update the contributor's fork. This will only work if the +# contributor has checked the "Allow edits by maintainers" box in the +# PR. If not, you will have to manually merge the rebased commits. +git push -f + +# If the force push was successful, you can now go into the GitHub UI +# and merge using the "Create a merge request" option. +# +# If the force push failed because the contributor did not check +# "Allow edits by maintainers", or if you prefer to merge manually, +# continue with the next steps. + +# Switch to the local master branch +git checkout master + +# Make sure the local master branch is up to date +git merge --ff-only origin/master + +# Merge in the rebased pull request branch **WITHOUT DOING A +# FAST-FORWARD MERGE** +git merge --no-ff "${PR_USER:?}-${PR_BRANCH:?}" + +# Review the commits before pushing +git log --graph --oneline --decorate origin/master.. + +# Push to ddclient master +git push origin master +``` diff -Nru ddclient-3.9.1/ddclient ddclient-3.10.0/ddclient --- ddclient-3.9.1/ddclient 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/ddclient 1970-01-01 00:00:00.000000000 +0000 @@ -1,5271 +0,0 @@ -#!/usr/bin/perl -w -#!/usr/local/bin/perl -w -###################################################################### -# -# DDCLIENT - a Perl client for updating DynDNS information -# -# Author: Paul Burry (paul+ddclient@burry.ca) -# ddclient-developers: see https://sourceforge.net/project/memberlist.php?group_id=116817 -# -# website: http://ddclient.sf.net -# -# Support for multiple IP numbers added by -# Astaro AG, Ingo Schwarze September 16, 2008 -# -# Support for multiple domain support for Namecheap by Robert Ian Hawdon 2010-09-03: https://robertianhawdon.me.uk/ -# -# Initial Cloudflare support by Ian Pye, updated by Robert Ian Hawdon 2012-07-16 -# Further updates by Peter Roberts to support the new API 2013-09-26, 2014-06-22: http://blog.peter-r.co.uk/ -# -# -###################################################################### -require 5.004; -use strict; -use Getopt::Long; -use Sys::Hostname; -use IO::Socket; -use Data::Validate::IP; - -my $version = "3.9.1"; -my $programd = $0; -$programd =~ s%^.*/%%; -my $program = $programd; -$program =~ s/d$//; -my $now = time; -my $hostname = hostname(); -my $etc = ($program =~ /test/i) ? './' : '/etc/ddclient/'; -my $cachedir = ($program =~ /test/i) ? './' : '/var/cache/ddclient/'; -my $savedir = ($program =~ /test/i) ? 'URL/' : '/tmp/'; -my $msgs = ''; -my $last_msgs = ''; - -use vars qw($file $lineno); -local $file = ''; -local $lineno = ''; - -$ENV{'PATH'} = (exists($ENV{PATH}) ? "$ENV{PATH}:" : "") . "/sbin:/usr/sbin:/bin:/usr/bin:/etc:/usr/lib:"; - -sub T_ANY {'any'}; -sub T_STRING {'string'}; -sub T_EMAIL {'e-mail address'}; -sub T_NUMBER {'number'}; -sub T_DELAY {'time delay (ie. 1d, 1hour, 1m)'}; -sub T_LOGIN {'login'}; -sub T_PASSWD {'password'}; -sub T_BOOL {'boolean value'}; -sub T_FQDN {'fully qualified host name'}; -sub T_OFQDN {'optional fully qualified host name'}; -sub T_FILE {'file name'}; -sub T_FQDNP {'fully qualified host name and optional port number'}; -sub T_PROTO {'protocol'} -sub T_USE {'ip strategy'} -sub T_IF {'interface'} -sub T_PROG {'program name'} -sub T_IP {'ip'} -sub T_POSTS {'postscript'}; - -## strategies for obtaining an ip address. -my %builtinweb = ( - 'dyndns' => { 'url' => 'http://checkip.dyndns.org/', 'skip' => - 'Current IP Address:', }, - 'dnspark' => { 'url' => 'http://ipdetect.dnspark.com/', 'skip' => 'Current Address:', }, - 'loopia' => { 'url' => 'http://dns.loopia.se/checkip/checkip.php', 'skip' => 'Current IP Address:', }, -); -my %builtinfw = ( - 'watchguard-soho' => { - 'name' => 'Watchguard SOHO FW', - 'url' => '/pubnet.htm', - 'skip' => 'NAME=IPAddress VALUE=', - }, - 'netopia-r910' => { - 'name' => 'Netopia R910 FW', - 'url' => '/WanEvtLog', - 'skip' => 'local:', - }, - 'smc-barricade' => { - 'name' => 'SMC Barricade FW', - 'url' => '/status.htm', - 'skip' => 'IP Address', - }, - 'smc-barricade-alt' => { - 'name' => 'SMC Barricade FW (alternate config)', - 'url' => '/status.HTM', - 'skip' => 'WAN IP', - }, - 'smc-barricade-7401bra' => { - 'name' => 'SMC Barricade 7401BRA FW', - 'url' => '/admin/wan1.htm', - 'skip' => 'IP Address', - }, - 'netgear-rt3xx' => { - 'name' => 'Netgear FW', - 'url' => '/mtenSysStatus.html', - 'skip' => 'IP Address', - }, - 'elsa-lancom-dsl10' => { - 'name' => 'ELSA LanCom DSL/10 DSL FW', - 'url' => '/config/1/6/8/3/', - 'skip' => 'IP.Address', - }, - 'elsa-lancom-dsl10-ch01' => { - 'name' => 'ELSA LanCom DSL/10 DSL FW (isdn ch01)', - 'url' => '/config/1/6/8/3/', - 'skip' => 'IP.Address.*?CH01', - }, - 'elsa-lancom-dsl10-ch02' => { - 'name' => 'ELSA LanCom DSL/10 DSL FW (isdn ch01)', - 'url' => '/config/1/6/8/3/', - 'skip' => 'IP.Address.*?CH02', - }, - 'linksys' => { - 'name' => 'Linksys FW', - 'url' => '/Status.htm', - 'skip' => 'WAN.*?Address', - }, - 'linksys-ver2' => { - 'name' => 'Linksys FW version 2', - 'url' => '/RouterStatus.htm', - 'skip' => 'WAN.*?Address', - }, - 'linksys-ver3' => { - 'name' => 'Linksys FW version 3', - 'url' => '/Status_Router.htm', - 'skip' => 'WAN.*?Address', - }, - 'linksys-wrt854g' => { - 'name' => 'Linksys WRT854G FW', - 'url' => '/Status_Router.asp', - 'skip' => 'IP Address:', - }, - 'maxgate-ugate3x00' => { - 'name' => 'MaxGate UGATE-3x00 FW', - 'url' => '/Status.htm', - 'skip' => 'WAN.*?IP Address', - }, - 'netcomm-nb3' => { - 'name' => 'NetComm NB3', - 'url' => '/MainPage?id=6', - 'skip' => 'ppp-0', - }, - '3com-3c886a' => { - 'name' => '3com 3c886a 56k Lan Modem', - 'url' => '/stat3.htm', - 'skip' => 'IP address in use', - }, - 'sohoware-nbg800' => { - 'name' => 'SOHOWare BroadGuard NBG800', - 'url' => '/status.htm', - 'skip' => 'Internet IP', - }, - 'xsense-aero' => { - 'name' => 'Xsense Aero', - 'url' => '/A_SysInfo.htm', - 'skip' => 'WAN.*?IP Address', - }, - 'alcatel-stp' => { - 'name' => 'Alcatel Speed Touch Pro', - 'url' => '/cgi/router/', - 'skip' => 'Brt', - }, - 'alcatel-510' => { - 'name' => 'Alcatel Speed Touch 510', - 'url' => '/cgi/ip/', - 'skip' => 'ppp', - }, - 'allnet-1298' => { - 'name' => 'Allnet 1298', - 'url' => '/cgi/router/', - 'skip' => 'WAN', - }, - '3com-oc-remote812' => { - 'name' => '3com OfficeConnect Remote 812', - 'url' => '/callEvent', - 'skip' => '.*LOCAL', - }, - 'e-tech' => { - 'name' => 'E-tech Router', - 'url' => '/Status.htm', - 'skip' => 'Public IP Address', - }, - 'cayman-3220h' => { - 'name' => 'Cayman 3220-H DSL', - 'url' => '/shell/show+ip+interfaces', - 'skip' => '.*inet', - }, - 'vigor-2200usb' => { - 'name' => 'Vigor 2200 USB', - 'url' => '/doc/online.sht', - 'skip' => 'PPPoA', - }, - 'dlink-614' => { - 'name' => 'D-Link DI-614+', - 'url' => '/st_devic.html', - 'skip' => 'WAN', - }, - 'dlink-604' => { - 'name' => 'D-Link DI-604', - 'url' => '/st_devic.html', - 'skip' => 'WAN.*?IP.*Address', - }, - 'olitec-SX200' => { - 'name' => 'olitec-SX200', - 'url' => '/doc/wan.htm', - 'skip' => 'st_wan_ip[0] = "', - }, - 'westell-6100' => { - 'name' => 'Westell C90-610015-06 DSL Router', - 'url' => '/advstat.htm', - 'skip' => 'IP.+?Address', - }, - '2wire' => { - 'name' => '2Wire 1701HG Gateway', - 'url' => '/xslt?PAGE=B01', - 'skip' => 'Internet Address:', - }, - 'linksys-rv042-wan1' => { - 'name' => 'Linksys RV042 Dual Homed Router WAN Port 2', - 'url' => '/home.htm', - 'skip' => 'WAN1 IP', - }, - 'linksys-rv042-wan2' => { - 'name' => 'Linksys RV042 Dual Homed Router WAN Port 2', - 'url' => '/home.htm', - 'skip' => 'WAN2 IP', - }, - 'netgear-rp614' => { - 'name' => 'Netgear RP614 FW', - 'url' => '/sysstatus.html', - 'skip' => 'IP Address', - }, - 'watchguard-edge-x' => { - 'name' => 'Watchguard Edge X FW', - 'url' => '/netstat.htm', - 'skip' => 'inet addr:', - }, - 'dlink-524' => { - 'name' => 'D-Link DI-524', - 'url' => '/st_device.html', - 'skip' => 'WAN.*?Addres', - }, - 'rtp300' => { - 'name' => 'Linksys RTP300', - 'url' => '/cgi-bin/webcm?getpage=%2Fusr%2Fwww_safe%2Fhtml%2Fstatus%2FRouter.html', - 'skip' => 'Internet.*?IP Address', - }, - 'netgear-wpn824' => { - 'name' => 'Netgear WPN824 FW', - 'url' => '/RST_status.htm', - 'skip' => 'IP Address', - }, - 'linksys-wcg200' => { - 'name' => 'Linksys WCG200 FW', - 'url' => '/RgStatus.asp', - 'skip' => 'WAN.IP.*?Address', - }, - 'netgear-dg834g' => { - 'name' => 'netgear-dg834g', - 'url' => '/setup.cgi?next_file=s_status.htm&todo=cfg_init', - 'skip' => '', - }, - 'netgear-wgt624' => { - 'name' => 'Netgear WGT624', - 'url' => '/RST_st_dhcp.htm', - 'skip' => 'IP Address', - }, - 'sveasoft' => { - 'name' => 'Sveasoft WRT54G/WRT54GS', - 'url' => '/Status_Router.asp', - 'skip' => 'var wan_ip', - }, - 'smc-barricade-7004vbr' => { - 'name' => 'SMC Barricade FW (7004VBR model config)', - 'url' => '/status_main.stm', - 'skip' => 'var wan_ip=', - }, - 'sitecom-dc202' => { - 'name' => 'Sitecom DC-202 FW', - 'url' => '/status.htm', - 'skip' => 'Internet IP Address', - }, -); -my %ip_strategies = ( - 'ip' => ": obtain IP from -ip {address}", - 'web' => ": obtain IP from an IP discovery page on the web", - 'fw' => ": obtain IP from the firewall specified by -fw {type|address}", - 'if' => ": obtain IP from the -if {interface}", - 'cmd' => ": obtain IP from the -cmd {external-command}", - 'cisco' => ": obtain IP from Cisco FW at the -fw {address}", - 'cisco-asa' => ": obtain IP from Cisco ASA at the -fw {address}", - map { $_ => sprintf ": obtain IP from %s at the -fw {address}", $builtinfw{$_}->{'name'} } keys %builtinfw, -); -sub ip_strategies_usage { - return map { sprintf(" -use=%-22s %s.", $_, $ip_strategies{$_}) } sort keys %ip_strategies; -} - -my %web_strategies = ( - 'dyndns'=> 1, - 'dnspark'=> 1, - 'loopia'=> 1, -); - -sub setv { - return { - 'type' => shift, - 'required' => shift, - 'cache' => shift, - 'config' => shift, - 'default' => shift, - 'minimum' => shift, - }; -}; -my %variables = ( - 'global-defaults' => { - 'daemon' => setv(T_DELAY, 0, 0, 1, 0, interval('60s')), - 'foreground' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'file' => setv(T_FILE, 0, 0, 1, "$etc$program.conf", undef), - 'cache' => setv(T_FILE, 0, 0, 1, "$cachedir$program.cache", undef), - 'pid' => setv(T_FILE, 0, 0, 1, "", undef), - 'proxy' => setv(T_FQDNP, 0, 0, 1, '', undef), - 'protocol' => setv(T_PROTO, 0, 0, 1, 'dyndns2', undef), - - 'use' => setv(T_USE, 0, 0, 1, 'ip', undef), - 'ip' => setv(T_IP, 0, 0, 1, undef, undef), - 'if' => setv(T_IF, 0, 0, 1, 'ppp0', undef), - 'if-skip' => setv(T_STRING,1, 0, 1, '', undef), - 'web' => setv(T_STRING,0, 0, 1, 'dyndns', undef), - 'web-skip' => setv(T_STRING,1, 0, 1, '', undef), - 'fw' => setv(T_ANY, 0, 0, 1, '', undef), - 'fw-skip' => setv(T_STRING,1, 0, 1, '', undef), - 'fw-banlocal' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'fw-login' => setv(T_LOGIN, 1, 0, 1, '', undef), - 'fw-password' => setv(T_PASSWD,1, 0, 1, '', undef), - 'cmd' => setv(T_PROG, 0, 0, 1, '', undef), - 'cmd-skip' => setv(T_STRING,1, 0, 1, '', undef), - - 'timeout' => setv(T_DELAY, 0, 0, 1, interval('120s'), interval('120s')), - 'retry' => setv(T_BOOL, 0, 0, 0, 0, undef), - 'force' => setv(T_BOOL, 0, 0, 0, 0, undef), - 'ssl' => setv(T_BOOL, 0, 0, 0, 0, undef), - 'ipv6' => setv(T_BOOL, 0, 0, 0, 0, undef), - 'syslog' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'facility' => setv(T_STRING,0, 0, 1, 'daemon', undef), - 'priority' => setv(T_STRING,0, 0, 1, 'notice', undef), - 'mail' => setv(T_EMAIL, 0, 0, 1, '', undef), - 'mail-failure' => setv(T_EMAIL, 0, 0, 1, '', undef), - - 'exec' => setv(T_BOOL, 0, 0, 1, 1, undef), - 'debug' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'verbose' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'quiet' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'help' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'test' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'geturl' => setv(T_STRING,0, 0, 0, '', undef), - - 'postscript' => setv(T_POSTS, 0, 0, 1, '', undef), - }, - 'service-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'members.dyndns.org', undef), - 'login' => setv(T_LOGIN, 1, 0, 1, '', undef), - 'password' => setv(T_PASSWD, 1, 0, 1, '', undef), - 'host' => setv(T_STRING, 1, 1, 1, '', undef), - - 'use' => setv(T_USE, 0, 0, 1, 'ip', undef), - 'if' => setv(T_IF, 0, 0, 1, 'ppp0', undef), - 'if-skip' => setv(T_STRING,0, 0, 1, '', undef), - 'web' => setv(T_STRING,0, 0, 1, 'dyndns', undef), - 'web-skip' => setv(T_STRING,0, 0, 1, '', undef), - 'fw' => setv(T_ANY, 0, 0, 1, '', undef), - 'fw-skip' => setv(T_STRING,0, 0, 1, '', undef), - 'fw-banlocal' => setv(T_BOOL, 0, 0, 1, 0, undef), - 'fw-login' => setv(T_LOGIN, 0, 0, 1, '', undef), - 'fw-password' => setv(T_PASSWD,0, 0, 1, '', undef), - 'cmd' => setv(T_PROG, 0, 0, 1, '', undef), - 'cmd-skip' => setv(T_STRING,0, 0, 1, '', undef), - 'ipv6' => setv(T_BOOL, 0, 0, 0, 0, undef), - 'ip' => setv(T_IP, 0, 1, 0, undef, undef), - 'wtime' => setv(T_DELAY, 0, 1, 1, 0, interval('30s')), - 'mtime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'atime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'status' => setv(T_ANY, 0, 1, 0, '', undef), - 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('30s'), 0), - 'max-interval' => setv(T_DELAY, 0, 0, 1, interval('25d'), 0), - 'min-error-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0), - - 'warned-min-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - }, - 'dyndns-common-defaults' => { - 'static' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'wildcard' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), - 'backupmx' => setv(T_BOOL, 0, 1, 1, 0, undef), - }, - 'easydns-common-defaults' => { - 'wildcard' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), - 'backupmx' => setv(T_BOOL, 0, 1, 1, 0, undef), - }, - 'dnspark-common-defaults' => { - 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), - 'mxpri' => setv(T_NUMBER, 0, 0, 1, 5, undef), - }, - 'noip-common-defaults' => { - 'static' => setv(T_BOOL, 0, 1, 1, 0, undef), - }, - 'noip-service-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'dynupdate.no-ip.com', undef), - 'login' => setv(T_LOGIN, 1, 0, 1, '', undef), - 'password' => setv(T_PASSWD, 1, 0, 1, '', undef), - 'host' => setv(T_STRING, 1, 1, 1, '', undef), - 'ip' => setv(T_IP, 0, 1, 0, undef, undef), - 'wtime' => setv(T_DELAY, 0, 1, 1, 0, interval('30s')), - 'mtime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'atime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'status' => setv(T_ANY, 0, 1, 0, '', undef), - 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('30s'), 0), - 'max-interval' => setv(T_DELAY, 0, 0, 1, interval('25d'), 0), - 'min-error-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0), - 'warned-min-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - }, - 'zoneedit-service-common-defaults' => { - 'zone' => setv(T_OFQDN, 0, 0, 1, undef, undef), - }, - 'dtdns-common-defaults' => { - 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), - 'client' => setv(T_STRING, 0, 1, 1, $program, undef), - }, - 'nsupdate-common-defaults' => { - 'ttl' => setv(T_NUMBER, 0, 1, 0, 600, undef), - 'zone' => setv(T_STRING, 1, 1, 1, '', undef), - 'tcp' => setv(T_BOOL, 0, 1, 1, 0, undef), - }, - 'cloudflare-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'api.cloudflare.com/client/v4', undef), - 'zone' => setv(T_FQDN, 1, 0, 1, '', undef), - 'static' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'wildcard' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), - 'backupmx' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'ttl' => setv(T_NUMBER, 1, 0, 1, 1, undef), - }, - 'googledomains-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'domains.google.com', undef), - }, - 'duckdns-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'www.duckdns.org', undef), - 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), - }, - 'freemyip-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'freemyip.com', undef), - 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), - }, - 'woima-common-defaults' => { - 'static' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'wildcard' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), - 'backupmx' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'custom' => setv(T_BOOL, 0, 1, 1, 0, undef), - 'script' => setv(T_STRING, 1, 1, 1, '/nic/update', undef), - }, - 'woima-service-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'dyn.woima.fi', undef), - 'login' => setv(T_LOGIN, 1, 0, 1, '', undef), - 'password' => setv(T_PASSWD, 1, 0, 1, '', undef), - 'ip' => setv(T_IP, 0, 1, 0, undef, undef), - 'wtime' => setv(T_DELAY, 0, 1, 1, 0, interval('30s')), - 'mtime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'atime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'status' => setv(T_ANY, 0, 1, 0, '', undef), - 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('30s'), 0), - 'max-interval' => setv(T_DELAY, 0, 0, 1, interval('25d'), 0), - 'min-error-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0), - 'warned-min-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, 0, undef), - }, - 'yandex-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'pddimp.yandex.ru', undef), - }, - 'dnsmadeeasy-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'cp.dnsmadeeasy.com', undef), - 'script' => setv(T_STRING, 1, 1, 1, '/servlet/updateip', undef), - }, - 'dondominio-common-defaults' => { - 'server' => setv(T_FQDNP, 1, 0, 1, 'dondns.dondominio.com', undef), - }, -); -my %services = ( - 'dyndns1' => { - 'updateable' => \&nic_dyndns2_updateable, - 'update' => \&nic_dyndns1_update, - 'examples' => \&nic_dyndns1_examples, - 'variables' => merge( - $variables{'dyndns-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'dyndns2' => { - 'updateable' => \&nic_dyndns2_updateable, - 'update' => \&nic_dyndns2_update, - 'examples' => \&nic_dyndns2_examples, - 'variables' => merge( - { 'custom' => setv(T_BOOL, 0, 1, 1, 0, undef), }, - { 'script' => setv(T_STRING, 1, 1, 1, '/nic/update', undef), }, -# { 'offline' => setv(T_BOOL, 0, 1, 1, 0, undef), }, - $variables{'dyndns-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'noip' => { - 'updateable' => undef, - 'update' => \&nic_noip_update, - 'examples' => \&nic_noip_examples, - 'variables' => merge( - { 'custom' => setv(T_BOOL, 0, 1, 1, 0, undef), }, - $variables{'noip-common-defaults'}, - $variables{'noip-service-common-defaults'}, - ), - }, - 'concont' => { - 'updateable' => undef, - 'update' => \&nic_concont_update, - 'examples' => \&nic_concont_examples, - 'variables' => merge( - $variables{'service-common-defaults'}, - { 'mx' => setv(T_OFQDN, 0, 1, 1, '', undef), }, - { 'wildcard' => setv(T_BOOL, 0, 1, 1, 0, undef), }, - ), - }, - 'dslreports1' => { - 'updateable' => undef, - 'update' => \&nic_dslreports1_update, - 'examples' => \&nic_dslreports1_examples, - 'variables' => merge( - { 'host' => setv(T_NUMBER, 1, 1, 1, 0, undef) }, - $variables{'service-common-defaults'}, - ), - }, - 'hammernode1' => { - 'updateable' => undef, - 'update' => \&nic_hammernode1_update, - 'examples' => \&nic_hammernode1_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'dup.hn.org', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'service-common-defaults'}, - ), - }, - 'zoneedit1' => { - 'updateable' => undef, - 'update' => \&nic_zoneedit1_update, - 'examples' => \&nic_zoneedit1_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'dynamic.zoneedit.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'service-common-defaults'}, - $variables{'zoneedit-service-common-defaults'}, - ), - }, - 'easydns' => { - 'updateable' => undef, - 'update' => \&nic_easydns_update, - 'examples' => \&nic_easydns_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'members.easydns.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'easydns-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'dnspark' => { - 'updateable' => undef, - 'update' => \&nic_dnspark_update, - 'examples' => \&nic_dnspark_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'www.dnspark.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'dnspark-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'namecheap' => { - 'updateable' => undef, - 'update' => \&nic_namecheap_update, - 'examples' => \&nic_namecheap_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'dynamicdns.park-your-domain.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, 0, interval('5m')),}, - $variables{'service-common-defaults'}, - ), - }, - 'nfsn' => { - 'updateable' => undef, - 'update' => \&nic_nfsn_update, - 'examples' => \&nic_nfsn_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'api.nearlyfreespeech.net', undef) }, - { 'min_interval' => setv(T_FQDNP, 0, 0, 1, 0, interval('5m')) }, - { 'ttl' => setv(T_NUMBER, 1, 0, 1, 300, undef) }, - { 'zone' => setv(T_FQDN, 1, 0, 1, undef, undef) }, - $variables{'service-common-defaults'}, - ), - }, - 'sitelutions' => { - 'updateable' => undef, - 'update' => \&nic_sitelutions_update, - 'examples' => \&nic_sitelutions_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'www.sitelutions.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, 0, interval('5m')),}, - $variables{'service-common-defaults'}, - ), - }, - 'freedns' => { - 'updateable' => undef, - 'update' => \&nic_freedns_update, - 'examples' => \&nic_freedns_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'freedns.afraid.org', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, 0, interval('5m')),}, - $variables{'service-common-defaults'}, - ), - }, - 'changeip' => { - 'updateable' => undef, - 'update' => \&nic_changeip_update, - 'examples' => \&nic_changeip_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'nic.changeip.com', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, 0, interval('5m')),}, - $variables{'service-common-defaults'}, - ), - }, - 'dtdns' => { - 'updateable' => undef, - 'update' => \&nic_dtdns_update, - 'examples' => \&nic_dtdns_examples, - 'variables' => merge( - $variables{'dtdns-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'nsupdate' => { - 'updateable' => undef, - 'update' => \&nic_nsupdate_update, - 'examples' => \&nic_nsupdate_examples, - 'variables' => merge( - { 'login' => setv(T_LOGIN, 1, 0, 1, '/usr/bin/nsupdate', undef), }, - $variables{'nsupdate-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'cloudflare' => { - 'updateable' => undef, - 'update' => \&nic_cloudflare_update, - 'examples' => \&nic_cloudflare_examples, - 'variables' => merge( - { 'server' => setv(T_FQDNP, 1, 0, 1, 'api.cloudflare.com/client/v4', undef) }, - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'cloudflare-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'googledomains' => { - 'updateable' => undef, - 'update' => \&nic_googledomains_update, - 'examples' => \&nic_googledomains_examples, - 'variables' => merge( - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'googledomains-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'duckdns' => { - 'updateable' => undef, - 'update' => \&nic_duckdns_update, - 'examples' => \&nic_duckdns_examples, - 'variables' => merge( - $variables{'duckdns-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'freemyip' => { - 'updateable' => undef, - 'update' => \&nic_freemyip_update, - 'examples' => \&nic_freemyip_examples, - 'variables' => merge( - $variables{'freemyip-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'woima' => { - 'updateable' => undef, - 'update' => \&nic_woima_update, - 'examples' => \&nic_woima_examples, - 'variables' => merge( - $variables{'woima-common-defaults'}, - $variables{'woima-service-common-defaults'}, - ), - }, - 'yandex' => { - 'updateable' => undef, - 'update' => \&nic_yandex_update, - 'examples' => \&nic_yandex_examples, - 'variables' => merge( - { 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0),}, - $variables{'yandex-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'dnsmadeeasy' => { - 'updateable' => undef, - 'update' => \&nic_dnsmadeeasy_update, - 'examples' => \&nic_dnsmadeeasy_examples, - 'variables' => merge( - $variables{'dnsmadeeasy-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, - 'dondominio' => { - 'updateable' => undef, - 'update' => \&nic_dondominio_update, - 'examples' => \&nic_dondominio_examples, - 'variables' => merge( - $variables{'dondominio-common-defaults'}, - $variables{'service-common-defaults'}, - ), - }, -); -$variables{'merged'} = merge($variables{'global-defaults'}, - $variables{'service-common-defaults'}, - $variables{'dyndns-common-defaults'}, - map { $services{$_}{'variables'} } keys %services, -); - -my @opt = ( - "usage: ${program} [options]", - "options are:", - [ "daemon", "=s", "-daemon delay : run as a daemon, specify delay as an interval." ], - [ "foreground", "!", "-foreground : do not fork" ], - [ "proxy", "=s", "-proxy host : use 'host' as the HTTP proxy" ], - [ "server", "=s", "-server host : update DNS information on 'host'" ], - [ "protocol", "=s", "-protocol type : update protocol used" ], - [ "file", "=s", "-file path : load configuration information from 'path'" ], - [ "cache", "=s", "-cache path : record address used in 'path'" ], - [ "pid", "=s", "-pid path : record process id in 'path'" ], - "", - [ "use", "=s", "-use which : how the should IP address be obtained." ], - &ip_strategies_usage(), - "", - [ "ip", "=s", "-ip address : set the IP address to 'address'" ], - "", - [ "if", "=s", "-if interface : obtain IP address from 'interface'" ], - [ "if-skip", "=s", "-if-skip pattern : skip any IP addresses before 'pattern' in the output of ifconfig {if}" ], - "", - [ "web", "=s", "-web provider|url : obtain IP address from provider's IP checking page" ], - [ "web-skip", "=s", "-web-skip pattern : skip any IP addresses before 'pattern' on the web provider|url" ], - "", - [ "fw", "=s", "-fw address|url : obtain IP address from firewall at 'address'" ], - [ "fw-skip", "=s", "-fw-skip pattern : skip any IP addresses before 'pattern' on the firewall address|url" ], - [ "fw-banlocal", "!", "-fw-banlocal : ignore local IP addresses on the firewall address|url" ], - [ "fw-login", "=s", "-fw-login login : use 'login' when getting IP from fw" ], - [ "fw-password", "=s", "-fw-password secret : use password 'secret' when getting IP from fw" ], - "", - [ "cmd", "=s", "-cmd program : obtain IP address from by calling {program}" ], - [ "cmd-skip", "=s", "-cmd-skip pattern : skip any IP addresses before 'pattern' in the output of {cmd}" ], - "", - [ "login", "=s", "-login user : login as 'user'" ], - [ "password", "=s", "-password secret : use password 'secret'" ], - [ "host", "=s", "-host host : update DNS information for 'host'" ], - "", - [ "options", "=s", "-options opt,opt : optional per-service arguments (see below)" ], - "", - [ "ssl", "!", "-{no}ssl : do updates over encrypted SSL connection" ], - [ "retry", "!", "-{no}retry : retry failed updates." ], - [ "force", "!", "-{no}force : force an update even if the update may be unnecessary" ], - [ "timeout", "=i", "-timeout max : wait at most 'max' seconds for the host to respond" ], - - [ "syslog", "!", "-{no}syslog : log messages to syslog" ], - [ "facility", "=s", "-facility {type} : log messages to syslog to facility {type}" ], - [ "priority", "=s", "-priority {pri} : log messages to syslog with priority {pri}" ], - [ "mail", "=s", "-mail address : e-mail messages to {address}" ], - [ "mail-failure","=s", "-mail-failure address : e-mail messages for failed updates to {address}" ], - [ "exec", "!", "-{no}exec : do {not} execute; just show what would be done" ], - [ "debug", "!", "-{no}debug : print {no} debugging information" ], - [ "verbose", "!", "-{no}verbose : print {no} verbose information" ], - [ "quiet", "!", "-{no}quiet : print {no} messages for unnecessary updates" ], - [ "ipv6", "!", "-{no}ipv6 : use ipv6" ], - [ "help", "", "-help : this message" ], - [ "postscript", "", "-postscript : script to run after updating ddclient, has new IP as param" ], - - [ "query", "!", "-{no}query : print {no} ip addresses and exit" ], - [ "test", "!", "" ], ## hidden - [ "geturl", "=s", "" ], ## hidden - "", - nic_examples(), - "$program version $version, ", - " originally written by Paul Burry, paul+ddclient\@burry.ca", - " project now maintained on http://ddclient.sourceforge.net" -); - -## process args -my ($opt_usage, %opt) = process_args(@opt); -my ($result, %config, %globals, %cache); -my $saved_cache = ''; -my %saved_opt = %opt; -$result = 'OK'; - -test_geturl(opt('geturl')) if opt('geturl'); - -## process help option -if (opt('help')) { - *STDERR = *STDOUT; - usage(0); -} - -## read config file because 'daemon' mode may be defined there. -read_config(define($opt{'file'}, default('file')), \%config, \%globals); -init_config(); -test_possible_ip() if opt('query'); - -if (!opt('daemon') && $programd =~ /d$/) { - $opt{'daemon'} = minimum('daemon'); -} -my $caught_hup = 0; -my $caught_term = 0; -my $caught_kill = 0; -$SIG{'HUP'} = sub { $caught_hup = 1; }; -$SIG{'TERM'} = sub { $caught_term = 1; }; -$SIG{'KILL'} = sub { $caught_kill = 1; }; -# don't fork() if foreground or force is on -if (opt('foreground') || opt('force')) { - ; -} elsif (opt('daemon')) { - $SIG{'CHLD'} = 'IGNORE'; - my $pid = fork; - if ($pid < 0) { - print STDERR "${program}: can not fork ($!)\n"; - exit -1; - } elsif ($pid) { - exit 0; - } - $SIG{'CHLD'} = 'DEFAULT'; - open(STDOUT, ">/dev/null"); - open(STDERR, ">/dev/null"); - open(STDIN, " 0) && !$caught_hup && !$caught_term && !$caught_kill) { - my $delay = $left > 10 ? 10 : $left; - - $0 = sprintf("%s - sleeping for %s seconds", $program, $left); - $left -= sleep $delay; - # preventing deep sleep - see [bugs:#46] - if ($left > $daemon) { - $left = $daemon; - } - } - $caught_hup = 0; - $result = 0; - - } elsif (! scalar(%config)) { - warning("no hosts to update.") unless !opt('quiet') || opt('verbose') || !$daemon; - $result = 1; - - } else { - $result = $result eq 'OK' ? 0 : 1; - } -} while ($daemon && !$result && !$caught_term && !$caught_kill); - -warning("caught SIGKILL; exiting") if $caught_kill; -unlink_pid(); -sendmail(); - -exit($result); - -###################################################################### -## runpostscript -###################################################################### - -sub runpostscript { - my ($ip) = @_; - - if ( defined $globals{postscript} ) { - if ( -x $globals{postscript}) { - system ("$globals{postscript} $ip &"); - } else { - warning ("Can not execute post script: %s", $globals{postscript}); - } - } -} - -###################################################################### -## update_nics -###################################################################### -sub update_nics { - my %examined = (); - my %iplist = (); - - foreach my $s (sort keys %services) { - my (@hosts, %ips) = (); - my $updateable = $services{$s}{'updateable'}; - my $update = $services{$s}{'update'}; - - foreach my $h (sort keys %config) { - next if $config{$h}{'protocol'} ne lc($s); - $examined{$h} = 1; - # we only do this once per 'use' and argument combination - my $use = opt('use', $h); - my $arg_ip = opt('ip', $h) || ''; - my $arg_fw = opt('fw', $h) || ''; - my $arg_if = opt('if', $h) || ''; - my $arg_web = opt('web', $h) || ''; - my $arg_cmd = opt('cmd', $h) || ''; - my $ip = ""; - if (exists $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}) { - $ip = $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}; - } else { - $ip = get_ip($use, $h); - if (!defined $ip || !$ip) { - warning("unable to determine IP address") - if !$daemon || opt('verbose'); - next; - } - if ($ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { - if( !ipv6_match($ip) ) { - warning("malformed IP address (%s)", $ip); - next; - } - } - $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd} = $ip; - } - $config{$h}{'wantip'} = $ip; - next if !nic_updateable($h, $updateable); - push @hosts, $h; - $ips{$ip} = $h; - } - if (@hosts) { - $0 = sprintf("%s - updating %s", $program, join(',', @hosts)); - &$update(@hosts); - runpostscript(join ' ', keys %ips); - } - } - foreach my $h (sort keys %config) { - if (!exists $examined{$h}) { - failed("%s was not updated because protocol %s is not supported.", - $h, define($config{$h}{'protocol'}, '') - ); - } - } - write_cache(opt('cache')); -} -###################################################################### -## unlink_pid() -###################################################################### -sub unlink_pid { - if (opt('pid') && opt('daemon')) { - unlink opt('pid'); - } -} - -###################################################################### -## write_pid() -###################################################################### -sub write_pid { - my $file = opt('pid'); - - if ($file && opt('daemon')) { - local *FD; - if (! open(FD, "> $file")) { - warning("Cannot create file '%s'. ($!)", $file); - - } else { - printf FD "$$\n"; - close(FD); - } - } -} - -###################################################################### -## write_cache($file) -###################################################################### -sub write_cache { - my ($file) = @_; - - ## merge the updated host entries into the cache. - foreach my $h (keys %config) { - if (! exists $cache{$h} || $config{$h}{'update'}) { - map {$cache{$h}{$_} = $config{$h}{$_} } @{$config{$h}{'cacheable'}}; - - } else { - map {$cache{$h}{$_} = $config{$h}{$_} } qw(atime wtime status); - } - } - - ## construct the cache file. - my $cache = ""; - foreach my $h (sort keys %cache) { - my $opt = join(',', map { "$_=".define($cache{$h}{$_},'') } sort keys %{$cache{$h}}); - - $cache .= sprintf "%s%s%s\n", $opt, ($opt ? ' ' : ''), $h; - } - $file = '' if defined($saved_cache) && $cache eq $saved_cache; - - ## write the updates and other entries to the cache file. - if ($file) { - $saved_cache = undef; - local *FD; - if (! open(FD, "> $file")) { - fatal("Cannot create file '%s'. ($!)", $file); - } - printf FD "## $program-$version\n"; - printf FD "## last updated at %s (%d)\n", prettytime($now), $now; - printf FD $cache; - - close(FD); - } -} -###################################################################### -## read_cache($file) - called before reading the .conf -###################################################################### -sub read_cache { - my $file = shift; - my $config = shift; - my $globals = {}; - - %{$config} = (); - ## read the cache file ignoring anything on the command-line. - if (-e $file) { - my %saved = %opt; - %opt = (); - $saved_cache = _read_config($config, $globals, "##\\s*$program-$version\\s*", $file); - %opt = %saved; - - foreach my $h (keys %cache) { - if (exists $config->{$h}) { - foreach (qw(atime mtime wtime ip status)) { - $config->{$h}{$_} = $cache{$h}{$_} if exists $cache{$h}{$_}; - } - } - } - } -} -###################################################################### -## parse_assignments(string) return (rest, %variables) -## parse_assignment(string) return (name, value, rest) -###################################################################### -sub parse_assignments { - my $rest = shift; - my @args = @_; - my %variables = (); - my ($name, $value); - - while (1) { - $rest =~ s/^\s+//; - ($name, $value, $rest) = parse_assignment($rest, @args); - if (defined $name) { - $variables{$name} = $value; - } else { - last; - } - } - return ($rest, %variables); -} -sub parse_assignment { - my $rest = shift; - my $stop = @_ ? shift : '[\n\s,]'; - my ($c, $name, $value); - my ($escape, $quote) = (0, ''); - - if ($rest =~ /^\s*([a-z][0-9a-z_-]*)=(.*)/i) { - ($name, $rest, $value) = ($1, $2, ''); - - while (length($c = substr($rest,0,1))) { - $rest = substr($rest,1); - if ($escape) { - $value .= $c; - $escape = 0; - } elsif ($c eq "\\") { - $escape = 1; - } elsif ($quote && $c eq $quote) { - $quote = '' - } elsif (!$quote && $c =~ /[\'\"]/) { - $quote = $c; - } elsif (!$quote && $c =~ /^${stop}/) { - last; - } else { - $value .= $c; - } - } - } - warning("assignment ended with an open quote") if $quote; - return ($name, $value, $rest); -} -###################################################################### -## read_config -###################################################################### -sub read_config { - my $file = shift; - my $config = shift; - my $globals = shift; - my %globals = (); - - _read_config($config, $globals, '', $file, %globals); -} -sub _read_config { - my $config = shift; - my $globals = shift; - my $stamp = shift; - local $file = shift; - my %globals = @_; - my %config = (); - my $content = ''; - - local *FD; - if (! open(FD, "< $file")) { - # fatal("Cannot open file '%s'. ($!)", $file); - warning("Cannot open file '%s'. ($!)", $file); - } - # Check for only owner has any access to config file - my ($dev, $ino, $mode, @statrest) = stat(FD); - if ($mode & 077) { - if (-f FD && (chmod 0600, $file)) { - warning("file $file must be accessible only by its owner (fixed)."); - } else { - # fatal("file $file must be accessible only by its owner."); - warning("file $file must be accessible only by its owner."); - } - } - - local $lineno = 0; - my $continuation = ''; - my %passwords = (); - while () { - s/[\r\n]//g; - - $lineno++; - - ## check for the program version stamp - if (($. == 1) && $stamp && ($_ !~ /^$stamp$/i)) { - warning("program version mismatch; ignoring %s", $file); - last; - } - if (/\\\s+$/) { - warning("whitespace follows the \\ at the end-of-line.\nIf you meant to have a line continuation, remove the trailing whitespace."); - } - - $content .= "$_\n" unless /^#/; - - ## parsing passwords is special - if (/^([^#]*\s)?([^#]*?password\S*?)\s*=\s*('.*'|[^']\S*)(.*)/) { - my ($head, $key, $value, $tail) = ($1 || '', $2, $3, $4); - $value = $1 if $value =~ /^'(.*)'$/; - $passwords{$key} = $value; - $_ = "${head}${key}=dummy${tail}"; - } - - ## remove comments - s/#.*//; - - ## handle continuation lines - $_ = "$continuation$_"; - if (/\\$/) { - chop; - $continuation = $_; - next; - } - $continuation = ''; - - s/^\s+//; # remove leading white space - s/\s+$//; # remove trailing white space - s/\s+/ /g; # canonify - next if /^$/; - - ## expected configuration line is: - ## [opt=value,opt=..] [host [login [password]]] - my %locals; - ($_, %locals) = parse_assignments($_); - s/\s*,\s*/,/g; - my @args = split; - - ## verify that keywords are valid...and check the value - foreach my $k (keys %locals) { - $locals{$k} = $passwords{$k} if defined $passwords{$k}; - if (!exists $variables{'merged'}{$k}) { - warning("unrecognized keyword '%s' (ignored)", $k); - delete $locals{$k}; - } else { - my $def = $variables{'merged'}{$k}; - my $value = check_value($locals{$k}, $def); - if (!defined($value)) { - warning("Invalid Value for keyword '%s' = '%s'", $k, $locals{$k}); - delete $locals{$k}; - } else { $locals{$k} = $value; } - } - } - if (exists($locals{'host'})) { - $args[0] = @args ? "$args[0],$locals{host}" : "$locals{host}"; - } - ## accumulate globals - if ($#args < 0) { - map { $globals{$_} = $locals{$_} } keys %locals; - } - - ## process this host definition - if (@args) { - my ($host, $login, $password) = @args; - - ## add in any globals.. - %locals = %{ merge(\%locals, \%globals) }; - - ## override login and password if specified the old way. - $locals{'login'} = $login if defined $login; - $locals{'password'} = $password if defined $password; - - ## allow {host} to be a comma separated list of hosts - foreach my $h (split_by_comma($host)) { - ## save a copy of the current globals - $config{$h} = { %locals }; - $config{$h}{'host'} = $h; - } - } - %passwords = (); - } - close(FD); - - warning("file ends while expecting a continuation line.") - if $continuation; - - %$globals = %globals; - %$config = %config; - - return $content; -} -###################################################################### -## init_config - -###################################################################### -sub init_config { - %opt = %saved_opt; - - ## - $opt{'quiet'} = 0 if opt('verbose'); - - ## infer the IP strategy if possible - $opt{'use'} = 'ip' if !define($opt{'use'}) && defined($opt{'ip'}); - $opt{'use'} = 'if' if !define($opt{'use'}) && defined($opt{'if'}); - $opt{'use'} = 'web' if !define($opt{'use'}) && defined($opt{'web'}); - - ## sanity check - $opt{'max-interval'} = min(interval(opt('max-interval')), interval(default('max-interval'))); - $opt{'min-interval'} = max(interval(opt('min-interval')), interval(default('min-interval'))); - $opt{'min-error-interval'} = max(interval(opt('min-error-interval')), interval(default('min-error-interval'))); - - $opt{'timeout'} = 0 if opt('timeout') < 0; - - ## only set $opt{'daemon'} if it has been explicitly passed in - if (define($opt{'daemon'},$globals{'daemon'},0)) { - $opt{'daemon'} = interval(opt('daemon')); - $opt{'daemon'} = minimum('daemon') - if ($opt{'daemon'} < minimum('daemon')); - } - - ## define or modify host options specified on the command-line - if (exists $opt{'options'} && defined $opt{'options'}) { - ## collect cmdline configuration options. - my %options = (); - foreach my $opt (split_by_comma($opt{'options'})) { - my ($name,$var) = split /\s*=\s*/, $opt; - $options{$name} = $var; - } - ## determine hosts specified with -host - my @hosts = (); - if (exists $opt{'host'}) { - foreach my $h (split_by_comma($opt{'host'})) { - push @hosts, $h; - } - } - ## and those in -options=... - if (exists $options{'host'}) { - foreach my $h (split_by_comma($options{'host'})) { - push @hosts, $h; - } - delete $options{'host'}; - } - ## merge options into host definitions or globals - if (@hosts) { - foreach my $h (@hosts) { - $config{$h} = merge(\%options, $config{$h}); - } - $opt{'host'} = join(',', @hosts); - } else { - %globals = %{ merge(\%options, \%globals) }; - } - } - - ## override global options with those on the command-line. - foreach my $o (keys %opt) { - if (defined $opt{$o} && exists $variables{'global-defaults'}{$o}) { - $globals{$o} = $opt{$o}; - } - } - - ## sanity check - if (defined $opt{'host'} && defined $opt{'retry'}) { - usage("options -retry and -host (or -option host=..) are mutually exclusive"); - } - - ## determine hosts to update (those on the cmd-line, config-file, or failed cached) - my @hosts = keys %config; - if (opt('host')) { - @hosts = split_by_comma($opt{'host'}); - } - if (opt('retry')) { - @hosts = map { $_ if $cache{$_}{'status'} ne 'good' } keys %cache; - } - - ## remove any other hosts - my %hosts; - map { $hosts{$_} = undef } @hosts; - map { delete $config{$_} unless exists $hosts{$_} } keys %config; - - ## collect the cacheable variables. - foreach my $proto (keys %services) { - my @cacheable = (); - foreach my $k (keys %{$services{$proto}{'variables'}}) { - push @cacheable, $k if $services{$proto}{'variables'}{$k}{'cache'}; - } - $services{$proto}{'cacheable'} = [ @cacheable ]; - } - - ## sanity check.. - ## make sure config entries have all defaults and they meet minimums - ## first the globals... - foreach my $k (keys %globals) { - my $def = $variables{'merged'}{$k}; - my $ovalue = define($globals{$k}, $def->{'default'}); - my $value = check_value($ovalue, $def); - if ($def->{'required'} && !defined $value) { - $value = default($k); - warning("'%s=%s' is an invalid %s. (using default of %s)", $k, $ovalue, $def->{'type'}, $value); - } - $globals{$k} = $value; - } - - ## now the host definitions... - HOST: - foreach my $h (keys %config) { - my $proto; - $proto = $config{$h}{'protocol'}; - $proto = opt('protocol') if !defined($proto); - - load_sha1_support($proto) if (grep (/^$proto$/, ("freedns", "nfsn"))); - load_json_support($proto) if (grep (/^$proto$/, ("cloudflare","yandex","nfsn"))); - - if (!exists($services{$proto})) { - warning("skipping host: %s: unrecognized protocol '%s'", $h, $proto); - delete $config{$h}; - - } else { - my $svars = $services{$proto}{'variables'}; - my $conf = { 'protocol' => $proto }; - - foreach my $k (keys %$svars) { - my $def = $svars->{$k}; - my $ovalue = define($config{$h}{$k}, $def->{'default'}); - my $value = check_value($ovalue, $def); - if ($def->{'required'} && !defined $value) { - warning("skipping host: %s: '%s=%s' is an invalid %s.", $h, $k, $ovalue, $def->{'type'}); - delete $config{$h}; - next HOST; - } - $conf->{$k} = $value; - - } - $config{$h} = $conf; - $config{$h}{'cacheable'} = [ @{$services{$proto}{'cacheable'}} ]; - } - } -} - -###################################################################### -## usage -###################################################################### -sub usage { - my $exitcode = 1; - $exitcode = shift if @_ != 0; # use first arg if given - my $msg = ''; - if (@_) { - my $format = shift; - $msg .= sprintf $format, @_; - 1 while chomp($msg); - $msg .= "\n"; - } - printf STDERR "%s%s\n", $msg, $opt_usage; - sendmail(); - exit $exitcode; -} - -###################################################################### -## process_args - -###################################################################### -sub process_args { - my @spec = (); - my $usage = ""; - my %opts = (); - - foreach (@_) { - if (ref $_) { - my ($key, $specifier, $arg_usage) = @$_; - my $value = default($key); - - ## add a option specifier - push @spec, $key . $specifier; - - ## define the default value which can be overwritten later - $opt{$key} = undef; - - next unless $arg_usage; - - ## add a line to the usage; - $usage .= " $arg_usage"; - if (defined($value) && $value ne '') { - $usage .= " (default: "; - if ($specifier eq '!') { - $usage .= "no" if ($specifier eq '!') && !$value; - $usage .= $key; - } else { - $usage .= $value; - } - $usage .= ")"; - } - $usage .= "."; - } else { - $usage .= $_; - } - $usage .= "\n"; - } - ## process the arguments - if (! GetOptions(\%opt, @spec)) { - $opt{"help"} = 1; - } - return ($usage, %opt); -} -###################################################################### -## test_possible_ip - print possible IPs -###################################################################### -sub test_possible_ip { - local $opt{'debug'} = 0; - - printf "use=ip, ip=%s address is %s\n", opt('ip'), define(get_ip('ip'), 'NOT FOUND') - if defined opt('ip'); - - { - local $opt{'use'} = 'if'; - foreach my $if (grep {/^[a-zA-Z]/} `ifconfig -a`) { - $if =~ s/:?\s.*//is; - local $opt{'if'} = $if; - printf "use=if, if=%s address is %s\n", opt('if'), define(get_ip('if'), 'NOT FOUND'); - } - } - if (opt('fw')) { - if (opt('fw') !~ m%/%) { - foreach my $fw (sort keys %builtinfw) { - local $opt{'use'} = $fw; - printf "use=$fw address is %s\n", define(get_ip($fw), 'NOT FOUND'); - } - } - local $opt{'use'} = 'fw'; - printf "use=fw, fw=%s address is %s\n", opt('fw'), define(get_ip(opt('fw')), 'NOT FOUND') - if ! exists $builtinfw{opt('fw')}; - - } - { - local $opt{'use'} = 'web'; - foreach my $web (sort keys %builtinweb) { - local $opt{'web'} = $web; - printf "use=web, web=$web address is %s\n", define(get_ip('web'), 'NOT FOUND'); - } - printf "use=web, web=%s address is %s\n", opt('web'), define(get_ip('web'), 'NOT FOUND') - if ! exists $builtinweb{opt('web')}; - } - if (opt('cmd')) { - local $opt{'use'} = 'cmd'; - printf "use=cmd, cmd=%s address is %s\n", opt('cmd'), define(get_ip('cmd'), 'NOT FOUND'); - } - exit 0 unless opt('debug'); -} -###################################################################### -## test_geturl - print (and save if -test) result of fetching a URL -###################################################################### -sub test_geturl { - my $url = shift; - - my $reply = geturl(opt('proxy'), $url, opt('login'), opt('password')); - print "URL $url\n";; - print defined($reply) ? $reply : "\n"; - exit; -} -###################################################################### -## load_file -###################################################################### -sub load_file { - my $file = shift; - my $buffer = ''; - - if (exists($ENV{'TEST_CASE'})) { - my $try = "$file-$ENV{'TEST_CASE'}"; - $file = $try if -f $try; - } - - local *FD; - if (open(FD, "< $file")) { - read(FD, $buffer, -s FD); - close(FD); - debug("Loaded %d bytes from %s", length($buffer), $file); - } else { - debug("Load failed from %s ($!)", $file); - } - return $buffer -} -###################################################################### -## save_file -###################################################################### -sub save_file { - my ($file, $buffer, $opt) = @_; - - $file .= "-$ENV{'TEST_CASE'}" if exists $ENV{'TEST_CASE'}; - if (defined $opt) { - my $i = 0; - while (-f "$file-$i") { - if ('unique' =~ /^$opt/i) { - my $a = join('\n', grep {!/^Date:/} split /\n/, $buffer); - my $b = join('\n', grep {!/^Date:/} split /\n/, load_file("$file-$i")); - last if $a eq $b; - } - $i++; - } - $file = "$file-$i"; - } - debug("Saving to %s", $file); - local *FD; - open(FD, "> $file") or return; - print FD $buffer; - close(FD); - return $buffer; -} -###################################################################### -## print_opt -## print_globals -## print_config -## print_cache -## print_info -###################################################################### -sub _print_hash { - my ($string, $ptr) = @_; - my $value = $ptr; - - if (! defined($ptr)) { - $value = ""; - } elsif (ref $ptr eq 'HASH') { - foreach my $key (sort keys %$ptr) { - _print_hash("${string}\{$key\}", $ptr->{$key}); - } - return; - } - printf "%-36s : %s\n", $string, $value; -} -sub print_hash { - my ($string, $hash) = @_; - printf "=== %s ====\n", $string; - _print_hash($string, $hash); -} -sub print_opt { print_hash("opt", \%opt); } -sub print_globals { print_hash("globals", \%globals); } -sub print_config { print_hash("config", \%config); } -sub print_cache { print_hash("cache", \%cache); } -sub print_info { - print_opt(); - print_globals(); - print_config(); - print_cache(); -} -###################################################################### -## pipecmd - run an external command -## logger -## sendmail -###################################################################### -sub pipecmd { - my $cmd = shift; - my $stdin = join("\n", @_); - my $ok = 0; - - ## remove trailing newlines - 1 while chomp($stdin); - - ## override when debugging. - $cmd = opt('exec') ? "| $cmd" : "> /dev/null"; - - ## execute the command. - local *FD; - if (! open(FD, $cmd)) { - printf STDERR "$program: cannot execute command %s.\n", $cmd; - - } elsif ($stdin && (! print FD "$stdin\n")) { - printf STDERR "$program: failed writting to %s.\n", $cmd; - close(FD); - - } elsif (! close(FD)) { - printf STDERR "$program: failed closing %s.($@)\n", $cmd; - - } elsif (opt('exec') && $?) { - printf STDERR "$program: failed %s. ($@)\n", $cmd; - - } else { - $ok = 1; - } - return $ok; -} -sub logger { - if (opt('syslog') && opt('facility') && opt('priority')) { - my $facility = opt('facility'); - my $priority = opt('priority'); - return pipecmd("logger -p$facility.$priority -t${program}\[$$\]", @_); - } - return 1; -} -sub sendmail { - my $recipients = opt('mail'); - - if (opt('mail-failure') && ($result ne 'OK' && $result ne '0')) { - $recipients = opt('mail-failure'); - } - if ($msgs && $recipients && $msgs ne $last_msgs) { - pipecmd("sendmail -oi $recipients", - "To: $recipients", - "Subject: status report from $program\@$hostname", - "\r\n", - $msgs, - "", - "regards,", - " $program\@$hostname (version $version)" - ); - } - $last_msgs = $msgs; - $msgs = ''; -} -###################################################################### -## split_by_comma -## merge -## default -## minimum -## opt -###################################################################### -sub split_by_comma { - my $string = shift; - - return split /\s*[, ]\s*/, $string if defined $string; - return (); -} -sub merge { - my %merged = (); - foreach my $h (@_) { - foreach my $k (keys %$h) { - $merged{$k} = $h->{$k} unless exists $merged{$k}; - } - } - return \%merged; -} -sub default { - my $v = shift; - return $variables{'merged'}{$v}{'default'}; -} -sub minimum { - my $v = shift; - return $variables{'merged'}{$v}{'minimum'}; -} -sub opt { - my $v = shift; - my $h = shift; - return $config{$h}{$v} if defined($h && $config{$h}{$v}); - return $opt{$v} if defined $opt{$v}; - return $globals{$v} if defined $globals{$v}; - return default($v) if defined default($v); - return undef; -} -sub min { - my $min = shift; - foreach my $arg (@_) { - $min = $arg if $arg < $min; - } - return $min; -} -sub max { - my $max = shift; - foreach my $arg (@_) { - $max = $arg if $arg > $max; - } - return $max; -} -###################################################################### -## define -###################################################################### -sub define { - foreach (@_) { - return $_ if defined $_; - } - return undef; -} -###################################################################### -## ynu -###################################################################### -sub ynu { - my ($value, $yes, $no, $undef) = @_; - - return $no if !defined($value) || !$value; - return $yes if $value eq '1'; - foreach (qw(yes true)) { - return $yes if $_ =~ /^$value/i; - } - foreach (qw(no false)) { - return $no if $_ =~ /^$value/i; - } - return $undef; -} -###################################################################### -## msg -## debug -## warning -## fatal -###################################################################### -sub _msg { - my $log = shift; - my $prefix = shift; - my $format = shift; - my $buffer = sprintf $format, @_; - chomp($buffer); - - $prefix = sprintf "%-9s ", $prefix if $prefix; - if ($file) { - $prefix .= "file $file"; - $prefix .= ", line $lineno" if $lineno; - $prefix .= ": "; - } - if ($prefix) { - $buffer = "$prefix$buffer"; - $buffer =~ s/\n/\n$prefix /g; - } - $buffer .= "\n"; - print $buffer; - - $msgs .= $buffer if $log; - logger($buffer) if $log; - -} -sub msg { _msg(0, '', @_); } -sub verbose { _msg(1, @_) if opt('verbose'); } -sub info { _msg(1, 'INFO:', @_) if opt('verbose'); } -sub debug { _msg(0, 'DEBUG:', @_) if opt('debug'); } -sub debug2 { _msg(0, 'DEBUG:', @_) if opt('debug') && opt('verbose');} -sub warning { _msg(1, 'WARNING:', @_); } -sub fatal { _msg(1, 'FATAL:', @_); sendmail(); exit(1); } -sub success { _msg(1, 'SUCCESS:', @_); } -sub failed { _msg(1, 'FAILED:', @_); $result = 'FAILED'; } -sub prettytime { return scalar(localtime(shift)); } - -sub prettyinterval { - my $interval = shift; - use integer; - my $s = $interval % 60; $interval /= 60; - my $m = $interval % 60; $interval /= 60; - my $h = $interval % 24; $interval /= 24; - my $d = $interval; - - my $string = ""; - $string .= "$d day" if $d; - $string .= "s" if $d > 1; - $string .= ", " if $string && $h; - $string .= "$h hour" if $h; - $string .= "s" if $h > 1; - $string .= ", " if $string && $m; - $string .= "$m minute" if $m; - $string .= "s" if $m > 1; - $string .= ", " if $string && $s; - $string .= "$s second" if $s; - $string .= "s" if $s > 1; - return $string; -} -sub interval { - my $value = shift; - if ($value =~ /^(\d+)(seconds|s)/i) { - $value = $1; - } elsif ($value =~ /^(\d+)(minutes|m)/i) { - $value = $1 * 60; - } elsif ($value =~ /^(\d+)(hours|h)/i) { - $value = $1 * 60*60; - } elsif ($value =~ /^(\d+)(days|d)/i) { - $value = $1 * 60*60*24; - } elsif ($value !~ /^\d+$/) { - $value = undef; - } - return $value; -} -sub interval_expired { - my ($host, $time, $interval) = @_; - - return 1 if !exists $cache{$host}; - return 1 if !exists $cache{$host}{$time} || !$cache{$host}{$time}; - return 1 if !exists $config{$host}{$interval} || !$config{$host}{$interval}; - - return $now > ($cache{$host}{$time} + $config{$host}{$interval}); -} - - - -###################################################################### -## check_value -###################################################################### -sub check_value { - my ($value, $def) = @_; - my $type = $def->{'type'}; - my $min = $def->{'minimum'}; - my $required = $def->{'required'}; - - if (!defined $value && !$required) { - ; - - } elsif ($type eq T_DELAY) { - $value = interval($value); - $value = $min if defined($value) && defined($min) && $value < $min; - - } elsif ($type eq T_NUMBER) { - return undef if $value !~ /^\d+$/; - $value = $min if defined($min) && $value < $min; - - } elsif ($type eq T_BOOL) { - if ($value =~ /^y(es)?$|^t(true)?$|^1$/i) { - $value = 1; - } elsif ($value =~ /^n(o)?$|^f(alse)?$|^0$/i) { - $value = 0; - } else { - return undef; - } - } elsif ($type eq T_FQDN || $type eq T_OFQDN && $value ne '') { - $value = lc $value; - return undef if $value !~ /[^.]\.[^.]/; - - } elsif ($type eq T_FQDNP) { - $value = lc $value; - return undef if $value !~ /[^.]\.[^.].*(:\d+)?$/; - - } elsif ($type eq T_PROTO) { - $value = lc $value; - return undef if ! exists $services{$value}; - - } elsif ($type eq T_USE) { - $value = lc $value; - return undef if ! exists $ip_strategies{$value}; - - } elsif ($type eq T_FILE) { - return undef if $value eq ""; - - } elsif ($type eq T_IF) { - return undef if $value !~ /^[a-zA-Z0-9:._-]+$/; - - } elsif ($type eq T_PROG) { - return undef if $value eq ""; - - } elsif ($type eq T_LOGIN) { - return undef if $value eq ""; - -# } elsif ($type eq T_PASSWD) { -# return undef if $value =~ /:/; - - } elsif ($type eq T_IP) { - if( !ipv6_match($value) ) { - return undef if $value !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/; - } - } - return $value; -} -###################################################################### -## encode_base64 - from MIME::Base64 -###################################################################### -sub encode_base64 ($;$) { - my $res = ''; - my $eol = $_[1]; - $eol = "\n" unless defined $eol; - pos($_[0]) = 0; # ensure start at the beginning - while ($_[0] =~ /(.{1,45})/gs) { - $res .= substr(pack('u', $1), 1); - chop($res); - } - $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs - - # fix padding at the end - my $padding = (3 - length($_[0]) % 3) % 3; - $res =~ s/.{$padding}$/'=' x $padding/e if $padding; - $res; -} -###################################################################### -## load_ssl_support -###################################################################### -sub load_ssl_support { - my $ssl_loaded = eval {require IO::Socket::SSL}; - unless ($ssl_loaded) { - fatal(<<"EOM"); -Error loading the Perl module IO::Socket::SSL needed for SSL connect. -On Debian, the package libio-socket-ssl-perl must be installed. -On Red Hat, the package perl-IO-Socket-SSL must be installed. -On Alpine, the package perl-io-socket-ssl must be installed. -EOM - } - import IO::Socket::SSL; - { no warnings; $IO::Socket::SSL::DEBUG = 0; } -} - -###################################################################### -## load_ipv6_support -###################################################################### -sub load_ipv6_support { - my $ipv6_loaded = eval {require IO::Socket::INET6}; - unless ($ipv6_loaded) { - fatal(<<"EOM"); -Error loading the Perl module IO::Socket::INET6 needed for ipv6 connect. -On Debian, the package libio-socket-inet6-perl must be installed. -On Red Hat, the package perl-IO-Socket-INET6 must be installed. -On Alpine, the package perl-io-socket-inet6 must be installed. -EOM - } - import IO::Socket::INET6; - { no warnings; $IO::Socket::INET6::DEBUG = 0; } -} - -###################################################################### -## load_sha1_support -###################################################################### -sub load_sha1_support { - my $why = shift; - my $sha1_loaded = eval {require Digest::SHA1}; - my $sha_loaded = eval {require Digest::SHA}; - unless ($sha1_loaded || $sha_loaded) { - fatal(<<"EOM"); -Error loading the Perl module Digest::SHA1 or Digest::SHA needed for $why update. -On Debian, the package libdigest-sha1-perl or libdigest-sha-perl must be installed. -EOM - } - if($sha1_loaded) { - import Digest::SHA1 (qw/sha1_hex/); - } elsif($sha_loaded) { - import Digest::SHA (qw/sha1_hex/); - } -} -###################################################################### -## load_json_support -###################################################################### -sub load_json_support { - my $why = shift; - my $json_loaded = eval {require JSON::PP}; - unless ($json_loaded) { - fatal(<<"EOM"); -Error loading the Perl module JSON::PP needed for $why update. -EOM - } - import JSON::PP (qw/decode_json/); -} -###################################################################### -## geturl -###################################################################### -sub geturl { - my $proxy = shift || ''; - my $url = shift || ''; - my $login = shift || ''; - my $password = shift || ''; - my $headers = shift || ''; - my $method = shift || 'GET'; - my $data = shift || ''; - my ($peer, $server, $port, $default_port, $use_ssl); - my ($sd, $rq, $request, $reply); - - debug("proxy = $proxy"); - debug("url = %s", $url); - ## canonify proxy and url - my $force_ssl; - $force_ssl = 1 if ($url =~ /^https:/); - $proxy =~ s%^https?://%%i; - $url =~ s%^https?://%%i; - $server = $url; - $server =~ s%/.*%%; - $url = "/" unless $url =~ m%/%; - $url =~ s%^[^/]*/%%; - - debug("server = $server"); - opt('fw') && debug("opt(fw = ",opt('fw'),")"); - $globals{'fw'} && debug("glo fw = $globals{'fw'}"); - #if ( $globals{'ssl'} and $server ne $globals{'fw'} ) { - ## always omit SSL for connections to local router - if ( $force_ssl || ($globals{'ssl'} and (caller(1))[3] ne 'main::get_ip') ) { - $use_ssl = 1; - $default_port = 443; - load_ssl_support; - } else { - $use_ssl = 0; - $default_port = 80; - } - - ## determine peer and port to use. - $peer = $proxy || $server; - $peer =~ s%/.*%%; - $port = $peer; - $port =~ s%^.*:%%; - $port = $default_port unless $port =~ /^\d+$/; - $peer =~ s%:.*$%%; - - my $to = sprintf "%s%s", $server, $proxy ? " via proxy $peer:$port" : ""; - verbose("CONNECT:", "%s", $to); - - $request = "$method "; - if (!$use_ssl) { - $request .= "http://$server" if $proxy; - } else { - $request .= "https://$server" if $proxy; - } - $request .= "/$url HTTP/1.0\n"; - $request .= "Host: $server\n"; - - my $auth = encode_base64("${login}:${password}", ""); - $request .= "Authorization: Basic $auth\n" if $login || $password; - $request .= "User-Agent: ${program}/${version}\n"; - if ($data) { - $request .= "Content-Type: application/x-www-form-urlencoded\n" if ! $headers =~ /^Content-Type: /; - $request .= "Content-Length: " . length($data) . "\n"; - } - $request .= "Connection: close\n"; - $request .= "$headers\n"; - $request .= "\n"; - $request .= $data; - - ## make sure newlines are for some pedantic proxy servers - ($rq = $request) =~ s/\n/\r\n/g; - - # local $^W = 0; - $0 = sprintf("%s - connecting to %s port %s", $program, $peer, $port); - if (! opt('exec')) { - debug("skipped network connection"); - verbose("SENDING:", "%s", $request); - } elsif ($use_ssl) { - $sd = IO::Socket::SSL->new( - PeerAddr => $peer, - PeerPort => $port, - Proto => 'tcp', - MultiHomed => 1, - Timeout => opt('timeout'), - ); - defined $sd or warning("cannot connect to $peer:$port socket: $@ " . IO::Socket::SSL::errstr()); - } elsif ($globals{'ipv6'}) { - load_ipv6_support; - $sd = IO::Socket::INET6->new( - PeerAddr => $peer, - PeerPort => $port, - Proto => 'tcp', - MultiHomed => 1, - Timeout => opt('timeout'), - ); - defined $sd or warning("cannot connect to $peer:$port socket: $@"); - } else { - $sd = IO::Socket::INET->new( - PeerAddr => $peer, - PeerPort => $port, - Proto => 'tcp', - MultiHomed => 1, - Timeout => opt('timeout'), - ); - defined $sd or warning("cannot connect to $peer:$port socket: $@"); - } - - if (defined $sd) { - ## send the request to the http server - verbose("CONNECTED: ", $use_ssl ? 'using SSL' : 'using HTTP'); - verbose("SENDING:", "%s", $request); - - $0 = sprintf("%s - sending to %s port %s", $program, $peer, $port); - my $result = syswrite $sd, $rq; - if ($result != length($rq)) { - warning("cannot send to $peer:$port ($!)."); - } else { - $0 = sprintf("%s - reading from %s port %s", $program, $peer, $port); - eval { - local $SIG{'ALRM'} = sub { die "timeout";}; - alarm(opt('timeout')) if opt('timeout') > 0; - while ($_ = <$sd>) { - $0 = sprintf("%s - read from %s port %s", $program, $peer, $port); - verbose("RECEIVE:", "%s", define($_, "")); - $reply .= $_ if defined $_; - } - if (opt('timeout') > 0) { - alarm(0); - } - }; - close($sd); - - if ($@ and $@ =~ /timeout/) { - warning("TIMEOUT: %s after %s seconds", $to, opt('timeout')); - $reply = ''; - } - $reply = '' if !defined $reply; - } - } - $0 = sprintf("%s - closed %s port %s", $program, $peer, $port); - - ## during testing simulate reading the URL - if (opt('test')) { - my $filename = "$server/$url"; - $filename =~ s|/|%2F|g; - if (opt('exec')) { - $reply = save_file("${savedir}$filename", $reply, 'unique'); - } else { - $reply = load_file("${savedir}$filename"); - } - } - - $reply =~ s/\r//g if defined $reply; - return $reply; -} -###################################################################### -## un_zero_pad -###################################################################### -sub un_zero_pad { - my $in_str = shift(@_); - my @out_str = (); - - if ($in_str eq '0.0.0.0') { - return $in_str; - } - - foreach my $block (split /\./, $in_str) { - $block =~ s/^0+//; - if ($block eq '') { - $block = '0'; - } - push @out_str, $block; - } - return join('.', @out_str); -} -###################################################################### -## filter_local -###################################################################### -sub filter_local { - my $in_ip = shift(@_); - - if ($in_ip eq '0.0.0.0') { - return $in_ip; - } - - my @guess_local = ( - '^10\.', - '^172\.(?:1[6-9]|2[0-9]|3[01])\.', - '^192\.168' - ); - foreach my $block (@guess_local) { - if ($in_ip =~ /$block/) { - return '0.0.0.0'; - } - } - return $in_ip; -} -###################################################################### -## get_ip -###################################################################### -sub get_ip { - my $use = lc shift; - my $h = shift; - my ($ip, $arg, $reply, $url, $skip) = (undef, opt($use, $h), ''); - $arg = '' unless $arg; - - if ($use eq 'ip') { - $ip = opt('ip', $h); - $arg = 'ip'; - - } elsif ($use eq 'if') { - $skip = opt('if-skip', $h) || ''; - $reply = `ifconfig $arg 2> /dev/null`; - $reply = `ip addr list dev $arg 2> /dev/null` if $?; - $reply = '' if $?; - - } elsif ($use eq 'cmd') { - if ($arg) { - $skip = opt('cmd-skip', $h) || ''; - $reply = `$arg`; - $reply = '' if $?; - } - - } elsif ($use eq 'web') { - $url = opt('web', $h) || ''; - $skip = opt('web-skip', $h) || ''; - - if (exists $builtinweb{$url}) { - $skip = $builtinweb{$url}->{'skip'} unless $skip; - $url = $builtinweb{$url}->{'url'}; - } - $arg = $url; - - if ($url) { - $reply = geturl(opt('proxy', $h), $url) || ''; - } - - } elsif (($use eq 'cisco')) { - # Stuff added to support Cisco router ip http daemon - # User fw-login should only have level 1 access to prevent - # password theft. This is pretty harmless. - my $queryif = opt('if', $h); - $skip = opt('fw-skip', $h) || ''; - - # Convert slashes to protected value "\/" - $queryif =~ s%\/%\\\/%g; - - # Protect special HTML characters (like '?') - $queryif =~ s/([\?&= ])/sprintf("%%%02x",ord($1))/ge; - - $url = "http://".opt('fw', $h)."/level/1/exec/show/ip/interface/brief/${queryif}/CR"; - $reply = geturl('', $url, opt('fw-login', $h), opt('fw-password', $h)) || ''; - $arg = $url; - - } elsif (($use eq 'cisco-asa')) { - # Stuff added to support Cisco ASA ip https daemon - # User fw-login should only have level 1 access to prevent - # password theft. This is pretty harmless. - my $queryif = opt('if', $h); - $skip = opt('fw-skip', $h) || ''; - - # Convert slashes to protected value "\/" - $queryif =~ s%\/%\\\/%g; - - # Protect special HTML characters (like '?') - $queryif =~ s/([\?&= ])/sprintf("%%%02x",ord($1))/ge; - - $url = "https://".opt('fw', $h)."/exec/show%20interface%20${queryif}"; - $reply = geturl('', $url, opt('fw-login', $h), opt('fw-password', $h)) || ''; - $arg = $url; - - } else { - $url = opt('fw', $h) || ''; - $skip = opt('fw-skip', $h) || ''; - - if (exists $builtinfw{$use}) { - $skip = $builtinfw{$use}->{'skip'} unless $skip; - $url = "http://${url}" . $builtinfw{$use}->{'url'} unless $url =~ /\//; - } - $arg = $url; - - if ($url) { - $reply = geturl('', $url, opt('fw-login', $h), opt('fw-password', $h)) || ''; - } - } - if (!defined $reply) { - $reply = ''; - } - if ($skip) { - $skip =~ s/ /\\s/is; - $reply =~ s/^.*?${skip}//is; - } - if ($reply =~ /^.*?\b(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\b.*/is) { - $ip = $1; - $ip = un_zero_pad($ip); - $ip = filter_local($ip) if opt('fw-banlocal', $h); - } elsif ( $ip = ipv6_match($reply) ) { - $ip = un_zero_pad($ip); - $ip = filter_local($ip) if opt('fw-banlocal', $h); - } else { - warning("found neither ipv4 nor ipv6 address"); - } - if (($use ne 'ip') && (define($ip,'') eq '0.0.0.0')) { - $ip = undef; - } - - debug("get_ip: using %s, %s reports %s", $use, $arg, define($ip, "")); - return $ip; -} - -###################################################################### -## ipv6_match determine ipv6 address from given string and return them -###################################################################### -sub ipv6_match { - my $content = shift; - my $omits; - my $ip = ""; - my $linenumbers = 0; - - my @values = split('\n', $content); - foreach my $val (@values) { - next unless $val =~ /((:{0,2}[A-F0-9]{1,4}){0,7}:{1,2}[A-F0-9]{1,4})/ai; # invalid char - my $parsed = $1; - - # check for at least 7 colons - my $count_colon = () = $parsed =~ /:/g; - if ($count_colon != 7) { - # or one double colon - my $count_double_colon = () = $parsed =~ /::/g; - if ($count_double_colon != 1) { - next - } - } - return $parsed; - } - return; -} - -###################################################################### -## group_hosts_by -###################################################################### -sub group_hosts_by { - my ($hosts, $attributes) = @_; - - my %groups = (); - foreach my $h (@$hosts) { - my @keys = (@$attributes, 'wantip'); - map { $config{$h}{$_} = '' unless exists $config{$h}{$_} } @keys; - my $sig = join(',', map { "$_=$config{$h}{$_}" } @keys); - - push @{$groups{$sig}}, $h; - } - return %groups; -} -###################################################################### -## encode_www_form_urlencoded -###################################################################### -sub encode_www_form_urlencoded { - my $formdata = shift; - - my $must_encode = qr'[<>"#%{}|\\^~\[\]`;/?:=&+]'; - my $encoded; - my $i = 0; - foreach my $k (keys %$formdata) { - my $kenc = $k; - my $venc = $formdata->{$k}; - - $kenc =~ s/($must_encode)/sprintf('%%%02X', ord($1))/ge; - $venc =~ s/($must_encode)/sprintf('%%%02X', ord($1))/ge; - - $kenc =~ s/ /+/g; - $venc =~ s/ /+/g; - - $encoded .= $kenc.'='.$venc; - if ($i < (keys %$formdata) - 1) { - $encoded .= '&'; - } - $i++; - } - - return $encoded; -} - -###################################################################### -## nic_examples -###################################################################### -sub nic_examples { - my $examples = ""; - my $separator = ""; - foreach my $s (sort keys %services) { - my $subr = $services{$s}{'examples'}; - my $example; - - if (defined($subr) && ($example = &$subr())) { - chomp($example); - $examples .= $example; - $examples .= "\n\n$separator"; - $separator = "\n"; - } - } - my $intro = < $now) { - warning("cannot update %s from %s to %s until after %s.", - $host, - ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), $ip, - prettytime($cache{$host}{'wtime'}) - ); - - } elsif ($cache{$host}{'mtime'} && interval_expired($host, 'mtime', 'max-interval')) { - warning("forcing update of %s from %s to %s; %s since last update on %s.", - $host, - ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), $ip, - prettyinterval($config{$host}{'max-interval'}), - prettytime($cache{$host}{'mtime'}) - ); - $update = 1; - - } elsif ((!exists($cache{$host}{'ip'})) || - ("$cache{$host}{'ip'}" ne "$ip")) { - if (($cache{$host}{'status'} eq 'good') && - !interval_expired($host, 'mtime', 'min-interval')) { - - warning("skipping update of %s from %s to %s.\nlast updated %s.\nWait at least %s between update attempts.", - $host, - ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), - $ip, - ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), - prettyinterval($config{$host}{'min-interval'}) - ) - if opt('verbose') || !define($cache{$host}{'warned-min-interval'}, 0); - - $cache{$host}{'warned-min-interval'} = $now; - - } elsif (($cache{$host}{'status'} ne 'good') && !interval_expired($host, 'atime', 'min-error-interval')) { - - warning("skipping update of %s from %s to %s.\nlast updated %s but last attempt on %s failed.\nWait at least %s between update attempts.", - $host, - ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), - $ip, - ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), - ($cache{$host}{'atime'} ? prettytime($cache{$host}{'atime'}) : ''), - prettyinterval($config{$host}{'min-error-interval'}) - ) - if opt('verbose') || !define($cache{$host}{'warned-min-error-interval'}, 0); - - $cache{$host}{'warned-min-error-interval'} = $now; - - } else { - $update = 1; - } - - } elsif (defined($sub) && &$sub($host)) { - $update = 1; - } elsif ((defined($cache{$host}{'static'}) && defined($config{$host}{'static'}) && - ($cache{$host}{'static'} ne $config{$host}{'static'})) || - (defined($cache{$host}{'wildcard'}) && defined($config{$host}{'wildcard'}) && - ($cache{$host}{'wildcard'} ne $config{$host}{'wildcard'})) || - (defined($cache{$host}{'mx'}) && defined($config{$host}{'mx'}) && - ($cache{$host}{'mx'} ne $config{$host}{'mx'})) || - (defined($cache{$host}{'backupmx'}) && defined($config{$host}{'backupmx'}) && - ($cache{$host}{'backupmx'} ne $config{$host}{'backupmx'})) ) { - info("updating %s because host settings have been changed.", $host); - $update = 1; - - } else { - success("%s: skipped: IP address was already set to %s.", $host, $ip) - if opt('verbose'); - } - $config{$host}{'status'} = define($cache{$host}{'status'},''); - $config{$host}{'update'} = $update; - if ($update) { - $config{$host}{'status'} = 'noconnect'; - $config{$host}{'atime'} = $now; - $config{$host}{'wtime'} = 0; - $config{$host}{'warned-min-interval'} = 0; - $config{$host}{'warned-min-error-interval'} = 0; - - delete $cache{$host}{'warned-min-interval'}; - delete $cache{$host}{'warned-min-error-interval'}; - } - - return $update; -} -###################################################################### -## header_ok -###################################################################### -sub header_ok { - my ($host, $line) = @_; - my $ok = 0; - - if ($line =~ m%^s*HTTP/1.*\s+(\d+)%i) { - my $result = $1; - - if ($result eq '200') { - $ok = 1; - - } elsif ($result eq '401') { - failed("updating %s: authorization failed (%s)", $host, $line); - } - - } else { - failed("updating %s: unexpected line (%s)", $host, $line); - } - return $ok; -} -###################################################################### -## nic_dyndns1_examples -###################################################################### -sub nic_dyndns1_examples { - return <\s*(.*)\s*%i; - $return_code = $1 if $line =~ m%^return\s+code\s*:\s*(.*)\s*$%i; - $error_code = $1 if $line =~ m%^error\s+code\s*:\s*(.*)\s*$%i; - } - - if ($return_code ne 'NOERROR' || $error_code ne 'NOERROR' || !$title) { - $config{$h}{'status'} = 'failed'; - $title = "incomplete response from $config{$h}{server}" unless $title; - warning("SENT: %s", $url) unless opt('verbose'); - warning("REPLIED: %s", $reply); - failed("updating %s: %s", $h, $title); - - } else { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("updating %s: %s: IP address set to %s (%s)", $h, $return_code, $ip, $title); - } - } -} -###################################################################### -## nic_dyndns2_updateable -###################################################################### -sub nic_dyndns2_updateable { - my $host = shift; - my $update = 0; - - if ($config{$host}{'mx'} ne $cache{$host}{'mx'}) { - info("forcing updating %s because 'mx' has changed to %s.", $host, $config{$host}{'mx'}); - $update = 1; - - } elsif ($config{$host}{'mx'} && (ynu($config{$host}{'backupmx'},1,2,3) ne ynu($config{$host}{'backupmx'},1,2,3))) { - info("forcing updating %s because 'backupmx' has changed to %s.", $host, ynu($config{$host}{'backupmx'},"YES","NO","NO")); - $update = 1; - - } elsif ($config{$host}{'static'} ne $cache{$host}{'static'}) { - - info("forcing updating %s because 'static' has changed to %s.", $host, ynu($config{$host}{'static'},"YES","NO","NO")); - $update = 1; - - } - return $update; -} -###################################################################### -## nic_dyndns2_examples -###################################################################### -sub nic_dyndns2_examples { - return < 'Bad authorization (username or password)', - 'badsys' => 'The system parameter given was not valid', - - 'notfqdn' => 'A Fully-Qualified Domain Name was not provided', - 'nohost' => 'The hostname specified does not exist in the database', - '!yours' => 'The hostname specified exists, but not under the username currently being used', - '!donator' => 'The offline setting was set, when the user is not a donator', - '!active' => 'The hostname specified is in a Custom DNS domain which has not yet been activated.', - 'abuse', => 'The hostname specified is blocked for abuse; you should receive an email notification ' . - 'which provides an unblock request link. More info can be found on ' . - 'https://www.dyndns.com/support/abuse.html', - - 'numhost' => 'System error: Too many or too few hosts found. Contact support@dyndns.org', - 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', - - 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', - ); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $ip = $config{$h}{'wantip'}; - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - ## Select the DynDNS system to update - my $url = "http://$config{$h}{'server'}$config{$h}{'script'}?system="; - if ($config{$h}{'custom'}) { - warning("updating %s: 'custom' and 'static' may not be used together. ('static' ignored)", $hosts) - if $config{$h}{'static'}; -# warning("updating %s: 'custom' and 'offline' may not be used together. ('offline' ignored)", $hosts) -# if $config{$h}{'offline'}; - $url .= 'custom'; - - } elsif ($config{$h}{'static'}) { -# warning("updating %s: 'static' and 'offline' may not be used together. ('offline' ignored)", $hosts) -# if $config{$h}{'offline'}; - $url .= 'statdns'; - - } else { - $url .= 'dyndns'; - } - - $url .= "&hostname=$hosts"; - $url .= "&myip="; - $url .= $ip if $ip; - - ## some args are not valid for a custom domain. - $url .= "&wildcard=ON" if ynu($config{$h}{'wildcard'}, 1, 0, 0); - if ($config{$h}{'mx'}) { - $url .= "&mx=$config{$h}{'mx'}"; - $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); - } - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); - last; - } - last if !header_ok($hosts, $reply); - - my @reply = split /\n/, $reply; - my $state = 'header'; - my $returnedip = $ip; - - foreach my $line (@reply) { - if ($state eq 'header') { - $state = 'body'; - - } elsif ($state eq 'body') { - $state = 'results' if $line eq ''; - - } elsif ($state =~ /^results/) { - $state = 'results2'; - - # bug #10: some dyndns providers does not return the IP so - # we can't use the returned IP - my ($status, $returnedip) = split / /, lc $line; - $ip = $returnedip if (not $ip); - my $h = shift @hosts; - - $config{$h}{'status'} = $status; - if ($status eq 'good') { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - success("updating %s: %s: IP address set to %s", $h, $status, $ip); - - } elsif (exists $errors{$status}) { - if ($status eq 'nochg') { - warning("updating %s: %s: %s", $h, $status, $errors{$status}); - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - - } else { - failed("updating %s: %s: %s", $h, $status, $errors{$status}); - } - - } elsif ($status =~ /w(\d+)(.)/) { - my ($wait, $units) = ($1, lc $2); - my ($sec, $scale) = ($wait, 1); - - ($scale, $units) = (1, 'seconds') if $units eq 's'; - ($scale, $units) = (60, 'minutes') if $units eq 'm'; - ($scale, $units) = (60*60, 'hours') if $units eq 'h'; - - $sec = $wait * $scale; - $config{$h}{'wtime'} = $now + $sec; - warning("updating %s: %s: wait $wait $units before further updates", $h, $status, $ip); - - } else { - failed("updating %s: %s: unexpected status (%s)", $h, $line); - } - } - } - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) - if $state ne 'results2'; - } -} - - -###################################################################### -## nic_noip_update -## Note: uses same features as nic_dyndns2_update, less return codes -###################################################################### -sub nic_noip_update { - debug("\nnic_noip_update -------------------"); - - ## group hosts with identical attributes together - my %groups = group_hosts_by([ @_ ], [ qw(login password server static custom wildcard mx backupmx) ]); - - my %errors = ( - 'badauth' => 'Invalid username or password', - 'badagent' => 'Invalid user agent', - 'nohost' => 'The hostname specified does not exist in the database', - '!donator' => 'The offline setting was set, when the user is not a donator', - 'abuse', => 'The hostname specified is blocked for abuse; open a trouble ticket at http://www.no-ip.com', - 'numhost' => 'System error: Too many or too few hosts found. open a trouble ticket at http://www.no-ip.com', - 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', - 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', - ); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $ip = $config{$h}{'wantip'}; - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - my $url = "http://$config{$h}{'server'}/nic/update?system="; - $url .= 'noip'; - $url .= "&hostname=$hosts"; - $url .= "&myip="; - $url .= $ip if $ip; - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); - last; - } - last if !header_ok($hosts, $reply); - - my @reply = split /\n/, $reply; - my $state = 'header'; - foreach my $line (@reply) { - if ($state eq 'header') { - $state = 'body'; - - } elsif ($state eq 'body') { - $state = 'results' if $line eq ''; - - } elsif ($state =~ /^results/) { - $state = 'results2'; - - my ($status, $ip) = split / /, lc $line; - my $h = shift @hosts; - - $config{$h}{'status'} = $status; - if ($status eq 'good') { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - success("updating %s: %s: IP address set to %s", $h, $status, $ip); - - } elsif (exists $errors{$status}) { - if ($status eq 'nochg') { - warning("updating %s: %s: %s", $h, $status, $errors{$status}); - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - - } else { - failed("updating %s: %s: %s", $h, $status, $errors{$status}); - } - - } elsif ($status =~ /w(\d+)(.)/) { - my ($wait, $units) = ($1, lc $2); - my ($sec, $scale) = ($wait, 1); - - ($scale, $units) = (1, 'seconds') if $units eq 's'; - ($scale, $units) = (60, 'minutes') if $units eq 'm'; - ($scale, $units) = (60*60, 'hours') if $units eq 'h'; - - $sec = $wait * $scale; - $config{$h}{'wtime'} = $now + $sec; - warning("updating %s: %s: wait $wait $units before further updates", $h, $status, $ip); - - } else { - failed("updating %s: %s: unexpected status (%s)", $h, $line); - } - } - } - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) - if $state ne 'results2'; - } -} -###################################################################### -## nic_noip_examples -###################################################################### -sub nic_noip_examples { - return </i, @reply) { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("updating %s: good: IP address set to %s", $h, $ip); - } else { - $config{$h}{'status'} = 'failed'; - warning("SENT: %s", $url) unless opt('verbose'); - warning("REPLIED: %s", $reply); - failed("updating %s: Invalid reply.", $h); - } - } -} -###################################################################### -## nic_zoneedit1_examples -###################################################################### -sub nic_zoneedit1_examples { - return < -# -# -###################################################################### -sub nic_zoneedit1_update { - debug("\nnic_zoneedit1_update -------------------"); - - ## group hosts with identical attributes together - my %groups = group_hosts_by([ @_ ], [ qw(login password server zone) ]); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $ip = $config{$h}{'wantip'}; - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - my $url = ''; - $url .= "http://$config{$h}{'server'}/auth/dynamic.html"; - $url .= "?host=$hosts"; - $url .= "&dnsto=$ip" if $ip; - $url .= "&zone=$config{$h}{'zone'}" if defined $config{$h}{'zone'}; - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); - last; - } - last if !header_ok($hosts, $reply); - - my @reply = split /\n/, $reply; - foreach my $line (@reply) { - if ($line =~ /^[^<]*<(SUCCESS|ERROR)\s+([^>]+)>(.*)/) { - my ($status, $assignments, $rest) = ($1, $2, $3); - my ($left, %var) = parse_assignments($assignments); - - if (keys %var) { - my ($status_code, $status_text, $status_ip) = ('999', '', $ip); - $status_code = $var{'CODE'} if exists $var{'CODE'}; - $status_text = $var{'TEXT'} if exists $var{'TEXT'}; - $status_ip = $var{'IP'} if exists $var{'IP'}; - - if ($status eq 'SUCCESS' || ($status eq 'ERROR' && $var{'CODE'} eq '707')) { - $config{$h}{'ip'} = $status_ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - - success("updating %s: IP address set to %s (%s: %s)", $h, $ip, $status_code, $status_text); - - } else { - $config{$h}{'status'} = 'failed'; - failed("updating %s: %s: %s", $h, $status_code, $status_text); - } - shift @hosts; - $h = $hosts[0]; - $hosts = join(',', @hosts); - } - $line = $rest; - redo if $line; - } - } - failed("updating %s: no response from %s", $hosts, $config{$h}{'server'}) - if @hosts; - } -} -###################################################################### -## nic_easydns_updateable -###################################################################### -sub nic_easydns_updateable { - my $host = shift; - my $update = 0; - - if ($config{$host}{'mx'} ne $cache{$host}{'mx'}) { - info("forcing updating %s because 'mx' has changed to %s.", $host, $config{$host}{'mx'}); - $update = 1; - - } elsif ($config{$host}{'mx'} && (ynu($config{$host}{'backupmx'},1,2,3) ne ynu($config{$host}{'backupmx'},1,2,3))) { - info("forcing updating %s because 'backupmx' has changed to %s.", $host, ynu($config{$host}{'backupmx'},"YES","NO","NO")); - $update = 1; - - } elsif ($config{$host}{'static'} ne $cache{$host}{'static'}) { - - info("forcing updating %s because 'static' has changed to %s.", $host, ynu($config{$host}{'static'},"YES","NO","NO")); - $update = 1; - - } - return $update; -} -###################################################################### -## nic_easydns_examples -###################################################################### -sub nic_easydns_examples { - return < [ $_ ] } @_; - - my %errors = ( - 'NOACCESS' => 'Authentication failed. This happens if the username/password OR host or domain are wrong.', - 'NOSERVICE'=> 'Dynamic DNS is not turned on for this domain.', - 'ILLEGAL' => 'Client sent data that is not allowed in a dynamic DNS update.', - 'TOOSOON' => 'Update frequency is too short.', - ); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $ip = $config{$h}{'wantip'}; - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - #'http://members.easydns.com/dyn/dyndns.php?hostname=test.burry.ca&myip=10.20.30.40&wildcard=ON' - - my $url; - $url = "http://$config{$h}{'server'}/dyn/dyndns.php?"; - $url .= "hostname=$hosts"; - $url .= "&myip="; - $url .= $ip if $ip; - $url .= "&wildcard=" . ynu($config{$h}{'wildcard'}, 'ON', 'OFF', 'OFF') if defined $config{$h}{'wildcard'}; - - if ($config{$h}{'mx'}) { - $url .= "&mx=$config{$h}{'mx'}"; - $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); - } - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); - last; - } - last if !header_ok($hosts, $reply); - - my @reply = split /\n/, $reply; - my $state = 'header'; - foreach my $line (@reply) { - if ($state eq 'header') { - $state = 'body'; - - } elsif ($state eq 'body') { - $state = 'results' if $line eq ''; - - } elsif ($state =~ /^results/) { - $state = 'results2'; - - my ($status) = $line =~ /^(\S*)\b.*/; - my $h = shift @hosts; - - $config{$h}{'status'} = $status; - if ($status eq 'NOERROR') { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - success("updating %s: %s: IP address set to %s", $h, $status, $ip); - - } elsif ($status =~ /TOOSOON/) { - ## make sure we wait at least a little - my ($wait, $units) = (5, 'm'); - my ($sec, $scale) = ($wait, 1); - - ($scale, $units) = (1, 'seconds') if $units eq 's'; - ($scale, $units) = (60, 'minutes') if $units eq 'm'; - ($scale, $units) = (60*60, 'hours') if $units eq 'h'; - $config{$h}{'wtime'} = $now + $sec; - warning("updating %s: %s: wait $wait $units before further updates", $h, $status, $ip); - - } elsif (exists $errors{$status}) { - failed("updating %s: %s: %s", $h, $line, $errors{$status}); - - } else { - failed("updating %s: %s: unexpected status (%s)", $h, $line); - } - last; - } - } - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) - if $state ne 'results2'; - } -} -###################################################################### - -###################################################################### -## nic_dnspark_updateable -###################################################################### -sub nic_dnspark_updateable { - my $host = shift; - my $update = 0; - - if ($config{$host}{'mx'} ne $cache{$host}{'mx'}) { - info("forcing updating %s because 'mx' has changed to %s.", $host, $config{$host}{'mx'}); - $update = 1; - - } elsif ($config{$host}{'mx'} && ($config{$host}{'mxpri'} ne $cache{$host}{'mxpri'})) { - info("forcing updating %s because 'mxpri' has changed to %s.", $host, $config{$host}{'mxpri'}); - $update = 1; - } - return $update; -} -###################################################################### -## nic_dnspark_examples -###################################################################### -sub nic_dnspark_examples { - return < [ $_ ] } @_; - - my %errors = ( - 'nochange' => 'No changes made to the hostname(s). Continual updates with no changes lead to blocked clients.', - 'nofqdn' => 'No valid FQDN (fully qualified domain name) was specified', - 'nohost'=> 'An invalid hostname was specified. This due to the fact the hostname has not been created in the system. Creating new host names via clients is not supported.', - 'abuse' => 'The hostname specified has been blocked for abuse.', - 'unauth' => 'The username specified is not authorized to update this hostname and domain.', - 'blocked' => 'The dynamic update client (specified by the user-agent) has been blocked from the system.', - 'notdyn' => 'The hostname specified has not been marked as a dynamic host. Hosts must be marked as dynamic in the system in order to be updated via clients. This prevents unwanted or accidental updates.', - ); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $ip = $config{$h}{'wantip'}; - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - #'http://www.dnspark.com:80/visitors/update.html?myip=10.20.30.40&hostname=test.burry.ca' - - my $url; - $url = "http://$config{$h}{'server'}/visitors/update.html"; - $url .= "?hostname=$hosts"; - $url .= "&myip="; - $url .= $ip if $ip; - - if ($config{$h}{'mx'}) { - $url .= "&mx=$config{$h}{'mx'}"; - $url .= "&mxpri=" . $config{$h}{'mxpri'}; - } - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); - last; - } - last if !header_ok($hosts, $reply); - - my @reply = split /\n/, $reply; - my $state = 'header'; - foreach my $line (@reply) { - if ($state eq 'header') { - $state = 'body'; - - } elsif ($state eq 'body') { - $state = 'results' if $line eq ''; - - } elsif ($state =~ /^results/) { - $state = 'results2'; - - my ($status) = $line =~ /^(\S*)\b.*/; - my $h = pop @hosts; - - $config{$h}{'status'} = $status; - if ($status eq 'ok') { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - success("updating %s: %s: IP address set to %s", $h, $status, $ip); - - } elsif ($status =~ /TOOSOON/) { - ## make sure we wait at least a little - my ($wait, $units) = (5, 'm'); - my ($sec, $scale) = ($wait, 1); - - ($scale, $units) = (1, 'seconds') if $units eq 's'; - ($scale, $units) = (60, 'minutes') if $units eq 'm'; - ($scale, $units) = (60*60, 'hours') if $units eq 'h'; - $config{$h}{'wtime'} = $now + $sec; - warning("updating %s: %s: wait $wait $units before further updates", $h, $status, $ip); - - } elsif (exists $errors{$status}) { - failed("updating %s: %s: %s", $h, $line, $errors{$status}); - - } else { - failed("updating %s: %s: unexpected status (%s)", $h, $line); - } - last; - } - } - failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) - if $state ne 'results2'; - } -} - -###################################################################### - -###################################################################### -## nic_namecheap_examples -###################################################################### -sub nic_namecheap_examples { - return <0/i, @reply) { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("updating %s: good: IP address set to %s", $h, $ip); - } else { - $config{$h}{'status'} = 'failed'; - warning("SENT: %s", $url) unless opt('verbose'); - warning("REPLIED: %s", $reply); - failed("updating %s: Invalid reply.", $h); - } - } -} - -###################################################################### - -###################################################################### -## nic_nfsn_examples -###################################################################### -sub nic_nfsn_examples { - return <{'error'}) { - failed("Invalid error response: %s", $resp); - return; - } - - failed($json->{'error'}); - if (defined $json->{'debug'}) { - failed($json->{'debug'}); - } -} - -###################################################################### -## nic_nfsn_update -## -## Written by John Brooks -## -## Based on API docs: https://members.nearlyfreespeech.net/wiki/API/Introduction -## Uses the API endpoints under https://api.nearlyfreespeech.net/dns/$zone/ -## -## NB: There is no "updateRR" API function; to update an existing RR, we use -## removeRR to delete the RR, and then addRR to re-add it with the new data. -## -###################################################################### -sub nic_nfsn_update { - debug("\nnic_nfsn_update -------------------"); - - ## update each configured host - foreach my $h (@_) { - my $zone = $config{$h}{'zone'}; - my $name; - - if ($h eq $zone) { - $name = ''; - } elsif ($h !~ /$zone$/) { - $config{$h}{'status'} = 'failed'; - failed("updating %s: %s is outside zone %s", $h, $h, - $zone); - next; - } else { - $name = $h; - $name =~ s/(.*)\.${zone}$/$1/; - } - - my $ip = delete $config{$h}{'wantip'}; - info("setting IP address to %s for %s", $ip, $h); - verbose("UPDATE", "updating %s", $h); - - my $list_path = "/dns/$zone/listRRs"; - my $list_body = encode_www_form_urlencoded({name => $name, - type => 'A'}); - my $list_resp = nic_nfsn_make_request($h, $list_path, 'POST', - $list_body); - if (!header_ok($h, $list_resp)) { - $config{$h}{'status'} = 'failed'; - nic_nfsn_handle_error($list_resp, $h); - next; - } - - $list_resp =~ s/^.*?\n\n//s; # Strip header - my $list = eval{decode_json($list_resp)}; - if ($@) { - $config{$h}{'status'} = 'failed'; - failed("updating %s: JSON decoding failure", $h); - next; - } - - my $rr_ttl = $config{$h}{'ttl'}; - - if (ref($list) eq 'ARRAY' && defined $list->[0]->{'data'}) { - my $rr_data = $list->[0]->{'data'}; - my $rm_path = "/dns/$zone/removeRR"; - my $rm_data = {name => $name, - type => 'A', - data => $rr_data}; - my $rm_body = encode_www_form_urlencoded($rm_data); - my $rm_resp = nic_nfsn_make_request($h, $rm_path, - 'POST', $rm_body); - if (!header_ok($h, $rm_resp)) { - $config{$h}{'status'} = 'failed'; - nic_nfsn_handle_error($rm_resp); - next; - } - } - - my $add_path = "/dns/$zone/addRR"; - my $add_data = {name => $name, - type => 'A', - data => $ip, - ttl => $rr_ttl}; - my $add_body = encode_www_form_urlencoded($add_data); - my $add_resp = nic_nfsn_make_request($h, $add_path, 'POST', - $add_body); - if (header_ok($h, $add_resp)) { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("updating %s: good: IP address set to %s", $h, $ip); - } else { - $config{$h}{'status'} = 'failed'; - nic_nfsn_handle_error($add_resp, $h); - } - } -} - -###################################################################### - -###################################################################### -## nic_sitelutions_examples -###################################################################### -sub nic_sitelutions_examples { - return < -## This returns a list of host|currentIP|updateURL lines. -## Pick the line that matches myhost, and fetch the URL. -## word 'Updated' for success, 'fail' for failure. -## -###################################################################### -sub nic_freedns_update { - - - debug("\nnic_freedns_update -------------------"); - - ## First get the list of updatable hosts - my $url; - $url = "http://$config{$_[0]}{'server'}/api/?action=getdyndns&sha=".&sha1_hex("$config{$_[0]}{'login'}|$config{$_[0]}{'password'}"); - my $reply = geturl(opt('proxy'), $url); - if (!defined($reply) || !$reply || !header_ok($_[0], $reply)) { - failed("updating %s: Could not connect to %s for site list.", $_[0], $url); - return; - } - my @lines = split("\n", $reply); - my %freedns_hosts; - grep { - my @rec = split(/\|/, $_); - $freedns_hosts{$rec[0]} = \@rec if ($#rec > 0); - } @lines; - if (!keys %freedns_hosts) { - failed("Could not get freedns update URLs from %s", $config{$_[0]}{'server'}); - return; - } - ## update each configured host - foreach my $h (@_) { - if(!$h){ next }; - my $ip = delete $config{$h}{'wantip'}; - info("setting IP address to %s for %s", $ip, $h); - verbose("UPDATE:","updating %s", $h); - - if($ip eq $freedns_hosts{$h}->[1]) { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("update not necessary %s: good: IP address already set to %s", $h, $ip); - } else { - my $reply = geturl(opt('proxy'), $freedns_hosts{$h}->[2]); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $h, $freedns_hosts{$h}->[2]); - last; - } - if(!header_ok($h, $reply)) { - $config{$h}{'status'} = 'failed'; - last; - } - - if($reply =~ /Updated.*$h.*to.*$ip/) { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("updating %s: good: IP address set to %s", $h, $ip); - } else { - $config{$h}{'status'} = 'failed'; - warning("SENT: %s", $freedns_hosts{$h}->[2]) unless opt('verbose'); - warning("REPLIED: %s", $reply); - failed("updating %s: Invalid reply.", $h); - } - } - } -} - -###################################################################### -## nic_changeip_examples -###################################################################### -sub nic_changeip_examples { -return < ## fully qualified hostname to update - -Example ${program}.conf file entries: - ## single host update - protocol=nsupdate \\ - server=ns1.example.com \\ - password=/etc/${program}/dyn.example.com.key \\ - zone=dyn.example.com \\ - ttl=3600 \\ - myhost.dyn.example.com - -EoEXAMPLE -} - -###################################################################### -## nic_nsupdate_update -## by Daniel Roethlisberger -###################################################################### -sub nic_nsupdate_update { - debug("\nnic_nsupdate_update -------------------"); - - ## group hosts with identical attributes together - my %groups = group_hosts_by([ @_ ], [ qw(login password server zone) ]); - - ## update each set of hosts that had similar configurations - foreach my $sig (keys %groups) { - my @hosts = @{$groups{$sig}}; - my $hosts = join(',', @hosts); - my $h = $hosts[0]; - my $binary = $config{$h}{'login'}; - my $keyfile = $config{$h}{'password'}; - my $server = $config{$h}{'server'}; - ## nsupdate requires a port number to be separated by whitepace, not colon - $server =~ s/:/ /; - my $zone = $config{$h}{'zone'}; - my $ip = $config{$h}{'wantip'}; - my $recordtype = ''; - if (is_ipv6($ip)) { - $recordtype = 'AAAA'; - } else { - $recordtype = 'A'; - } - delete $config{$_}{'wantip'} foreach @hosts; - - info("setting IP address to %s for %s", $ip, $hosts); - verbose("UPDATE:","updating %s", $hosts); - - ## send separate requests for each zone with all hosts in that zone - my $instructions = <{result}) { - failed ("invalid json or result."); - next; - } - - # Pull the ID out of the json, messy - my ($zone_id) = map { $_->{name} eq $config{$key}{'zone'} ? $_->{id} : () } @{ $response->{result} }; - unless($zone_id) { - failed("updating %s: No zone ID found.", $config{$key}{'zone'}); - next; - } - info("zone ID is $zone_id"); - - # Get DNS record ID - $url = "https://$config{$key}{'server'}/zones/$zone_id/dns_records?"; - if (is_ipv6($ip)) { - $url .= "type=AAAA&name=$domain"; - } else { - $url .= "type=A&name=$domain"; - } - - $reply = geturl(opt('proxy'), $url, undef, undef, $headers); - unless ($reply) { - failed("updating %s: Could not connect to %s.", $domain, $config{$key}{'server'}); - last; - } - last if !header_ok($domain, $reply); - - # Strip header - $reply =~ s/^.*?\n\n//s; - $response = eval {decode_json($reply)}; - if (!defined $response || !defined $response->{result}) { - failed ("invalid json or result."); - next; - } - - # Pull the ID out of the json, messy - my ($dns_rec_id) = map { $_->{name} eq $domain ? $_->{id} : () } @{ $response->{result} }; - unless($dns_rec_id) { - failed("updating %s: No DNS record ID found.", $domain); - next; - } - info("DNS record ID is $dns_rec_id"); - - # Set domain - $url = "https://$config{$key}{'server'}/zones/$zone_id/dns_records/$dns_rec_id"; - my $data = "{\"content\":\"$ip\"}"; - $reply = geturl(opt('proxy'), $url, undef, undef, $headers, "PATCH", $data); - unless ($reply) { - failed("updating %s: Could not connect to %s.", $domain, $config{$domain}{'server'}); - last; - } - last if !header_ok($domain, $reply); - - # Strip header - $reply =~ s/^.*?\n\n//s; - $response = eval {decode_json($reply)}; - if (!defined $response || !defined $response->{result}) { - failed ("invalid json or result."); - } else { - success ("%s -- Updated Successfully to %s", $domain, $ip); - - } - - # Cache - $config{$key}{'ip'} = $ip; - $config{$key}{'mtime'} = $now; - $config{$key}{'status'} = 'good'; - } - } -} -###################################################################### -## nic_yandex_examples -###################################################################### -sub nic_yandex_examples { - return <{success} eq 'error') { - failed ("%s", $response->{error}); - next; - } - - # Pull the ID out of the json - my ($id) = map { $_->{fqdn} eq $host ? $_->{record_id} : () } @{ $response->{records} }; - unless($id) { - failed("updating %s: DNS record ID not found.", $host); - next; - } - - # Update the DNS record - $url = "https://$config{$host}{'server'}/api2/admin/dns/edit"; - my $data = "domain="; - $data .= $config{$key}{'login'}; - $data .= "&record_id="; - $data .= $id; - $data .= "&content="; - $data .= $ip if $ip; - - $reply = geturl(opt('proxy'), $url, '', '', $headers, 'POST', $data); - unless ($reply) { - failed("updating %s: Could not connect to %s.", $host, $config{$host}{'server'}); - last; - } - last if !header_ok($host, $reply); - - # Strip header - $reply =~ s/^.*?\n\n//s; - $response = eval { decode_json($reply) }; - if ($response->{success} eq 'error') { - failed ("%s", $response->{error}); - } else { - success ("%s -- Updated Successfully to %s", $host, $ip); - } - - # Cache - $config{$host}{'ip'} = $ip; - $config{$host}{'mtime'} = $now; - $config{$host}{'status'} = 'good'; - } - } -} - -###################################################################### -## nic_duckdns_examples -###################################################################### -sub nic_duckdns_examples { - return < 'Bad authorization (username or password)', - 'badsys' => 'The system parameter given was not valid', - - 'notfqdn' => 'A Fully-Qualified Domain Name was not provided', - 'nohost' => 'The hostname specified does not exist in the database', - '!yours' => 'The hostname specified exists, but not under the username currently being used', - '!donator' => 'The offline setting was set, when the user is not a donator', - '!active' => 'The hostname specified is in a Custom DNS domain which has not yet been activated.', - 'abuse', => 'The hostname specified is blocked for abuse; you should receive an email notification ' . - 'which provides an unblock request link. More info can be found on ' . - 'https://www.dyndns.com/support/abuse.html', - - 'numhost' => 'System error: Too many or too few hosts found. Contact support@dyndns.org', - 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', - - 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', - ); - - my @hosts = @_; - foreach my $key (keys @hosts) { - my $h = $hosts[$key]; - my $ip = $config{$h}{'wantip'}; - delete $config{$h}{'wantip'}; - - info("setting IP address to %s for %s", $ip, $h); - verbose("UPDATE:","updating %s", $h); - - ## Select the DynDNS system to update - my $url = "http://$config{$h}{'server'}$config{$h}{'script'}?system="; - if ($config{$h}{'custom'}) { - warning("updating %s: 'custom' and 'static' may not be used together. ('static' ignored)", $h) - if $config{$h}{'static'}; - # warning("updating %s: 'custom' and 'offline' may not be used together. ('offline' ignored)", $h) - # if $config{$h}{'offline'}; - $url .= 'custom'; - - } elsif ($config{$h}{'static'}) { - # warning("updating %s: 'static' and 'offline' may not be used together. ('offline' ignored)", $h) - # if $config{$h}{'offline'}; - $url .= 'statdns'; - - } else { - $url .= 'dyndns'; - } - - $url .= "&hostname=$h"; - $url .= "&myip="; - $url .= $ip if $ip; - - ## some args are not valid for a custom domain. - $url .= "&wildcard=ON" if ynu($config{$h}{'wildcard'}, 1, 0, 0); - if ($config{$h}{'mx'}) { - $url .= "&mx=$config{$h}{'mx'}"; - $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); - } - - my $reply = geturl(opt('proxy'), $url, $config{$h}{'login'}, $config{$h}{'password'}); - if (!defined($reply) || !$reply) { - failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); - last; - } - last if !header_ok($h, $reply); - - my @reply = split /\n/, $reply; - my $state = 'header'; - my $returnedip = $ip; - - foreach my $line (@reply) { - if ($state eq 'header') { - $state = 'body'; - - } elsif ($state eq 'body') { - $state = 'results' if $line eq ''; - - } elsif ($state =~ /^results/) { - $state = 'results2'; - - # bug #10: some dyndns providers does not return the IP so - # we can't use the returned IP - my ($status, $returnedip) = split / /, lc $line; - $ip = $returnedip if (not $ip); - #my $h = shift @hosts; - - $config{$h}{'status'} = $status; - if ($status eq 'good') { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - success("updating %s: %s: IP address set to %s", $h, $status, $ip); - - } elsif (exists $errors{$status}) { - if ($status eq 'nochg') { - warning("updating %s: %s: %s", $h, $status, $errors{$status}); - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - - } else { - failed("updating %s: %s: %s", $h, $status, $errors{$status}); - } - - } elsif ($status =~ /w(\d+)(.)/) { - my ($wait, $units) = ($1, lc $2); - my ($sec, $scale) = ($wait, 1); - - ($scale, $units) = (1, 'seconds') if $units eq 's'; - ($scale, $units) = (60, 'minutes') if $units eq 'm'; - ($scale, $units) = (60*60, 'hours') if $units eq 'h'; - - $sec = $wait * $scale; - $config{$h}{'wtime'} = $now + $sec; - warning("updating %s: %s: wait $wait $units before further updates", $h, $status, $ip); - - } else { - failed("updating %s: %s: unexpected status (%s)", $h, $line); - } - } - } - failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}) - if $state ne 'results2'; - } -} - -###################################################################### -## nic_dondominio_examples -###################################################################### -sub nic_dondominio_examples { - return < 'Invalid username or password, or invalid IP syntax', - 'error-auth-suspend' => 'User has had their account suspended due to complaints or misuse of the service.', - 'error-auth-voided' => 'User has had their account permanently revoked.', - 'error-record-invalid' =>'Record ID number does not exist in the system.', - 'error-record-auth' => 'User does not have access to this record.', - 'error-record-ip-same' => 'No update required.', - 'error-system' => 'General system error which is caught and recognized by the system.', - 'error' => 'General system error unrecognized by the system.', - 'success' => 'Record successfully updated!', - ); - - ## update each configured host - ## should improve to update in one pass - foreach my $h (@_) { - my $ip = delete $config{$h}{'wantip'}; - info("Setting IP address to %s for %s", $ip, $h); - verbose("UPDATE:","Updating %s", $h); - - # Set the URL that we're going to to update - my $url; - $url = $globals{'ssl'} ? "https://" : "http://"; - $url .= $config{$h}{'server'}.$config{$h}{'script'}; - $url .= "?username=$config{$h}{'login'}"; - $url .= "&password=$config{$h}{'password'}"; - $url .= "&ip=$ip"; - $url .= "&id=$h"; - - # Try to get URL - my $reply = geturl(opt('proxy'), $url); - - # No response, declare as failed - if (!defined($reply) || !$reply) { - failed("Updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); - last; - } - last if !header_ok($h, $reply); - - my @reply = split /\n/, $reply; - my $returned = pop(@reply); - if ($returned =~ 'success') - { - $config{$h}{'ip'} = $ip; - $config{$h}{'mtime'} = $now; - $config{$h}{'status'} = 'good'; - success("Updating %s: good: IP address set to %s", $h, $ip); - } - else - { - $config{$h}{'status'} = 'failed'; - failed("Updating %s: Server said: '$returned': $messages{$returned}", $h); - } - } -} - -###################################################################### -# vim: ai ts=4 sw=4 tw=78 : - - -__END__ diff -Nru ddclient-3.9.1/ddclient.conf.in ddclient-3.10.0/ddclient.conf.in --- ddclient-3.9.1/ddclient.conf.in 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/ddclient.conf.in 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,317 @@ +###################################################################### +## +## Define default global variables with lines like: +## var=value [, var=value]* +## These values will be used for each following host unless overridden +## with a local variable definition. +## +## Define local variables for one or more hosts with: +## var=value [, var=value]* host.and.domain[,host2.and.domain...] +## +## Lines can be continued on the following line by ending the line +## with a \ +## +## +## Warning: not all supported routers or dynamic DNS services +## are mentioned here. +## +###################################################################### +daemon=300 # check every 300 seconds +syslog=yes # log update msgs to syslog +mail=root # mail all msgs to root +mail-failure=root # mail failed update msgs to root +pid=@runstatedir@/ddclient.pid # record PID in file. +ssl=yes # use ssl-support. Works with + # ssl-library +# postscript=script # run script after updating. The + # new IP is added as argument. +# +#use=watchguard-soho, fw=192.168.111.1:80 # via Watchguard's SOHO FW +#use=netopia-r910, fw=192.168.111.1:80 # via Netopia R910 FW +#use=smc-barricade, fw=192.168.123.254:80 # via SMC's Barricade FW +#use=netgear-rt3xx, fw=192.168.0.1:80 # via Netgear's internet FW +#use=linksys, fw=192.168.1.1:80 # via Linksys's internet FW +#use=maxgate-ugate3x00, fw=192.168.0.1:80 # via MaxGate's UGATE-3x00 FW +#use=elsa-lancom-dsl10, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router +#use=elsa-lancom-dsl10-ch01, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router +#use=elsa-lancom-dsl10-ch02, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router +#use=alcatel-stp, fw=10.0.0.138:80 # via Alcatel Speed Touch Pro +#use=xsense-aero, fw=192.168.1.1:80 # via Xsense Aero Router +#use=allnet-1298, fw=192.168.1.1:80 # via AllNet 1298 DSL Router +#use=3com-oc-remote812, fw=192.168.0.254:80 # via 3com OfficeConnect Remote 812 +#use=e-tech, fw=192.168.1.1:80 # via E-tech Router +#use=cayman-3220h, fw=192.168.0.1:1080 # via Cayman 3220-H DSL Router +# +#fw-login=admin, fw-password=XXXXXX # FW login and password +# +## To obtain an IP address from FW status page (using fw-login, fw-password) +#use=fw, fw=192.168.1.254/status.htm, fw-skip='IP Address' # found after IP Address +# +## To obtain an IP address from Web status page (using the proxy if defined) +## by default, checkip.dyndns.org is used if you use the dyndns protocol. +## Using use=web is enough to get it working. +## WARNING: set deamon at least to 600 seconds if you use checkip or you could +## get banned from their service. +#use=web, web=checkip.dyndns.org/, web-skip='IP Address' # found after IP Address +# +#use=ip, ip=127.0.0.1 # via static IP's +#use=if, if=eth0 # via interfaces +#use=web # via web +# +#protocol=dyndns2 # default protocol +#proxy=fasthttp.sympatico.ca:80 # default proxy +#server=members.dyndns.org # default server +#server=members.dyndns.org:8245 # default server (bypassing proxies) + +#login=your-login # default login +#password=test # default password +#mx=mx.for.your.host # default MX +#backupmx=yes|no # host is primary MX? +#wildcard=yes|no # add wildcard CNAME? + +## +## dyndns.org dynamic addresses +## +## (supports variables: wildcard,mx,backupmx) +## +# server=members.dyndns.org, \ +# protocol=dyndns2 \ +# your-dynamic-host.dyndns.org + +## +## dyndns.org static addresses +## +## (supports variables: wildcard,mx,backupmx) +## +# static=yes, \ +# server=members.dyndns.org, \ +# protocol=dyndns2 \ +# your-static-host.dyndns.org + +## +## dyndns.org custom addresses +## +## (supports variables: wildcard,mx,backupmx) +## +# custom=yes, \ +# server=members.dyndns.org, \ +# protocol=dyndns2 \ +# your-domain.top-level,your-other-domain.top-level + +## +## ZoneEdit (zoneedit.com) +## +# server=dynamic.zoneedit.com, \ +# protocol=zoneedit1, \ +# login=your-zoneedit-login, \ +# password=your-zoneedit-password \ +# your.any.domain,your-2nd.any.dom + +## +## EasyDNS (easydns.com) +## +# server=members.easydns.com, \ +# protocol=easydns, \ +# login=your-easydns-login, \ +# password=your-easydns-password \ +# your.any.domain,your-2nd.any.domain + +## +## dslreports.com dynamic-host monitoring +## +# server=members.dslreports.com \ +# protocol=dslreports1, \ +# login=dslreports-login, \ +# password=dslreports-password \ +# dslreports-unique-id + +## +## OrgDNS.org account-configuration +## +# use=web, web=members.orgdns.org/nic/ip +# protocol=dyndns2 +# server=www.orgdns.org \ +# login=yourLoginName \ +# password=yourPassword \ +# yourSubdomain.orgdns.org + +## +## NameCheap (namecheap.com) +## +# protocol=namecheap, \ +# server=dynamicdns.park-your-domain.com, \ +# login=example.com, \ +# password=example.com-password \ +# subdomain.example.com + +## +## NearlyFreeSpeech.NET (nearlyfreespeech.net) +## +# protocol = nfsn, \ +# login=member-login, \ +# password=api-key, \ +# zone=example.com \ +# example.com,subdomain.example.com + +## +## Loopia (loopia.se) +## +# use=web, web=loopia +# protocol=dyndns2 +# server=dns.loopia.se +# script=/XDynDNSServer/XDynDNS.php +# login=my-loopia.se-login +# password=my-loopia.se-password +# my.domain.tld,other.domain.tld + +## +## NoIP (noip.com) +## +# protocol=noip, \ +# ssl=yes, \ +# server=dynupdate.no-ip.com, \ +# login=your-noip-login, \ +# password=your-noip-password, \ +# your-host.domain.com, your-2nd-host.domain.com + +## +## ChangeIP (changeip.com) +## +## single host update +# protocol=changeip, \ +# login=my-my-changeip.com-login, \ +# password=my-changeip.com-password \ +# myhost.changeip.org + +## +## CloudFlare (www.cloudflare.com) +## +#protocol=cloudflare, \ +#zone=domain.tld, \ +#ttl=1, \ +#login=your-login-email, \ # Only needed if you are using your global API key. If you are using an API token, set it to "token" (wihtout double quotes). +#password=APIKey \ # This is either your global API key, or an API token. If you are using an API token, it must have the permissions "Zone - DNS - Edit" and "Zone - Zone - Read". The Zone resources must be "Include - All zones". +#domain.tld,my.domain.tld + +## +## Gandi (gandi.net) +## +## Single host update +# protocol=gandi, \ +# zone=example.com, \ +# password=my-gandi-api-key, \ +# ttl=3h \ +# myhost.example.com + +## +## Google Domains (www.google.com/domains) +## +# protocol=googledomains, +# login=my-auto-generated-username, +# password=my-auto-generated-password +# my.domain.tld, otherhost.domain.tld + +## +## Duckdns (http://www.duckdns.org/) +## +# +# protocol=duckdns, \ +# password=my-auto-generated-password \ +# hostwithoutduckdnsorg + +## +## Freemyip (http://freemyip.com/) +## +# +# protocol=freemyip, +# password=my-token +# myhost + +## +## MyOnlinePortal (http://myonlineportal.net) +## +# # ipv6=yes # optional +# use=web, web=myonlineportal.net/checkip +# # use=if, if=eth0 # alternative to use=web +# # if-skip=Scope:Link # alternative to use=web +# protocol=dyndns2 +# ssl=yes +# login=your-myonlineportal-username +# password=your-myonlineportal-password +# domain.myonlineportal.net + +## +## nsupdate.info IPV4(https://www.nsupdate.info) +## +#use=web, web=http://ipv4.nsupdate.info/myip +#protocol=dyndns2 +#server=ipv4.nsupdate.info +#login=domain.nsupdate.info +#password='123' +#domain.nsupdate.info + +## +## nsupdate.info IPV6 (https://www.nsupdate.info) +## ddclient releases <= 3.8.1 do not support IPv6 +## +#usev6=if, if=eth0 +#protocol=dyndns2 +#server=ipv6.nsupdate.info +#login=domain.nsupdate.info +#password='123' +#domain.nsupdate.info + +## +## Yandex.Mail for Domain (domain.yandex.com) +## +# protocol=yandex, \ +# login=domain.tld, \ +# password=yandex-pdd-token \ +# my.domain.tld,other.domain.tld \ + +## +## DNS Made Easy (https://dnsmadeeasy.com) +## +# protocol=dnsmadeeasy, +# login=your-account-email-address +# password=your-generated-password +# your-numeric-record-id-1,your-numeric-record-id-2,... + +## +## OVH DynHost (https://ovh.com) +## +# protocol=ovh, +# login=example.com-dynhostuser, +# password=your_password +# test.example.com + +## +## ClouDNS (https://www.cloudns.net) +## +# protocol=cloudns, \ +# dynurl=https://ipv4.cloudns.net/api/dynamicURL/?q=Njc1OTE2OjY3Njk0NDM6YTk2, \ +# myhost.example.com + +## +## dinahosting (https://dinahosting.com) +## +# protocol=dinahosting, \ +# login=myusername, \ +# password=mypassword \ +# myhost.mydomain.com + +## +## dnsexit (www.dnsexit.com) +## +#protocol=dnsexit, \ +#login=myusername, \ +#password=mypassword, \ +#subdomain-1.domain.com,subdomain-2.domain.com + +## +## Njal.la (http://njal.la/) +## +# protocol=njalla, +# password=mypassword +# quietreply=no|yes +# my-domain.com diff -Nru ddclient-3.9.1/ddclient.in ddclient-3.10.0/ddclient.in --- ddclient-3.9.1/ddclient.in 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/ddclient.in 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,7185 @@ +#!/usr/bin/perl +###################################################################### +# +# DDCLIENT - a Perl client for updating DynDNS information +# +# Author: Paul Burry (paul+ddclient@burry.ca) +# ddclient developers: see https://github.com/orgs/ddclient/people +# +# website: https://ddclient.net +# +# Support for multiple IP numbers added by +# Astaro AG, Ingo Schwarze September 16, 2008 +# +# Support for multiple domain support for Namecheap by Robert Ian Hawdon 2010-09-03: https://robertianhawdon.me.uk/ +# +# Initial Cloudflare support by Ian Pye, updated by Robert Ian Hawdon 2012-07-16 +# Further updates by Peter Roberts to support the new API 2013-09-26, 2014-06-22: http://blog.peter-r.co.uk/ +# +# +###################################################################### +package ddclient; +require v5.10.1; +use strict; +use warnings; +use File::Basename; +use File::Path qw(make_path); +use File::Temp; +use Getopt::Long; +use IO::Socket::INET; +use Socket qw(AF_INET AF_INET6 PF_INET PF_INET6); +use Sys::Hostname; + +use version 0.77; our $VERSION = version->declare('v3.10.0'); +(my $version = $VERSION->stringify()) =~ s/^v//; +my $programd = $0; +$programd =~ s%^.*/%%; +my $program = $programd; +$program =~ s/d$//; +my $now = time; +my $hostname = hostname(); + +# subst_var(subst, default) returns subst unless it looks like @foo@ in which case it returns +# default. The @foo@ strings are expected to be replaced by make; this function makes it possible +# to run this file as a Perl script before those substitutions are made. +sub subst_var { + my ($subst, $default) = @_; + return $default if $subst =~ qr'^@\w+@$'; + return $subst; +} + +my $etc = subst_var('@sysconfdir@', '/etc/ddclient'); +my $cachedir = subst_var('@localstatedir@', '/var') . '/cache/ddclient'; +my $savedir = '/tmp'; +if ($program =~ /test/i) { + $etc = '.'; + $cachedir = '.'; + $savedir = 'URL'; +} + +my $msgs = ''; +my $last_msgs = ''; + +## If run as *d (e.g., ddclientd) then daemonize by default (but allow +## flags and options to override). +my $daemon_default = ($programd =~ /d$/) ? interval('5m') : 0; + +use vars qw($file $lineno); +local $file = ''; +local $lineno = ''; + +$ENV{'PATH'} = (exists($ENV{PATH}) ? "$ENV{PATH}:" : "") . "/sbin:/usr/sbin:/bin:/usr/bin:/etc:/usr/lib:"; + +our %globals; +my ($result, %config, %cache); +my $saved_cache; +my %saved_opt; +my $daemon; +# Control how many times warning message logged for invalid IP addresses +my (%warned_ip, %warned_ipv4, %warned_ipv6); +my $inv_ip_warn_count = opt('max-warn') // 1; + +sub T_ANY { 'any' } +sub T_STRING { 'string' } +sub T_EMAIL { 'e-mail address' } +sub T_NUMBER { 'number' } +sub T_DELAY { 'time delay (ie. 1d, 1hour, 1m)' } +sub T_LOGIN { 'login' } +sub T_PASSWD { 'password' } +sub T_BOOL { 'boolean value' } +sub T_FQDN { 'fully qualified host name' } +sub T_OFQDN { 'optional fully qualified host name' } +sub T_FILE { 'file name' } +sub T_FQDNP { 'fully qualified host name and optional port number' } +sub T_PROTO { 'protocol' } +sub T_USE { 'ip strategy' } +sub T_USEV4 { 'ipv4 strategy' } +sub T_USEV6 { 'ipv6 strategy' } +sub T_IF { 'interface' } +sub T_PROG { 'program name' } +sub T_IP { 'ip' } +sub T_IPV4 { 'ipv4' } +sub T_IPV6 { 'ipv6' } +sub T_POSTS { 'postscript' } + +## strategies for obtaining an ip address. +my %builtinweb = ( + 'dyndns' => {'url' => 'http://checkip.dyndns.org/', 'skip' => 'Current IP Address:'}, + 'freedns' => {'url' => 'https://freedns.afraid.org/dynamic/check.php'}, + 'googledomains' => {'url' => 'https://domains.google.com/checkip'}, + 'he' => {'url' => 'https://checkip.dns.he.net/'}, + 'ip4only.me' => {'url' => 'https://ip4only.me/api/'}, + 'ip6only.me' => {'url' => 'https://ip6only.me/api/'}, + 'ipify-ipv4' => {'url' => 'https://api.ipify.org/'}, + 'ipify-ipv6' => {'url' => 'https://api6.ipify.org/'}, + 'loopia' => {'url' => 'https://dns.loopia.se/checkip/checkip.php', 'skip' => 'Current IP Address:'}, + 'myonlineportal' => {'url' => 'https://myonlineportal.net/checkip'}, + 'noip-ipv4' => {'url' => 'http://ip1.dynupdate.no-ip.com/'}, + 'noip-ipv6' => {'url' => 'http://ip1.dynupdate6.no-ip.com/'}, + 'nsupdate.info-ipv4' => {'url' => 'http://ipv4.nsupdate.info/myip'}, + 'nsupdate.info-ipv6' => {'url' => 'http://ipv6.nsupdate.info/myip'}, + 'zoneedit' => {'url' => 'https://dynamic.zoneedit.com/checkip.html'}, +); +my %builtinfw = ( + '2wire' => { + 'name' => '2Wire 1701HG Gateway', + 'url' => '/xslt?PAGE=B01', + 'skip' => 'Internet Address:', + }, + '3com-3c886a' => { + 'name' => '3com 3c886a 56k Lan Modem', + 'url' => '/stat3.htm', + 'skip' => 'IP address in use', + }, + '3com-oc-remote812' => { + 'name' => '3com OfficeConnect Remote 812', + 'url' => '/callEvent', + 'skip' => '.*LOCAL', + }, + 'alcatel-510' => { + 'name' => 'Alcatel Speed Touch 510', + 'url' => '/cgi/ip/', + 'skip' => 'ppp', + }, + 'alcatel-530' => { + 'name' => 'Alcatel/Thomson SpeedTouch 530', + 'url' => '/cgi/status/', + 'skip' => 'IP Address', + }, + 'alcatel-stp' => { + 'name' => 'Alcatel Speed Touch Pro', + 'url' => '/cgi/router/', + 'skip' => 'Brt', + }, + 'allnet-1298' => { + 'name' => 'Allnet 1298', + 'url' => '/cgi/router/', + 'skip' => 'WAN', + }, + 'cayman-3220h' => { + 'name' => 'Cayman 3220-H DSL', + 'url' => '/shell/show+ip+interfaces', + 'skip' => '.*inet', + }, + 'dlink-524' => { + 'name' => 'D-Link DI-524', + 'url' => '/st_device.html', + 'skip' => 'WAN.*?Addres', + }, + 'dlink-604' => { + 'name' => 'D-Link DI-604', + 'url' => '/st_devic.html', + 'skip' => 'WAN.*?IP.*Address', + }, + 'dlink-614' => { + 'name' => 'D-Link DI-614+', + 'url' => '/st_devic.html', + 'skip' => 'WAN', + }, + 'e-tech' => { + 'name' => 'E-tech Router', + 'url' => '/Status.htm', + 'skip' => 'Public IP Address', + }, + 'elsa-lancom-dsl10' => { + 'name' => 'ELSA LanCom DSL/10 DSL FW', + 'url' => '/config/1/6/8/3/', + 'skip' => 'IP.Address', + }, + 'elsa-lancom-dsl10-ch01' => { + 'name' => 'ELSA LanCom DSL/10 DSL FW (isdn ch01)', + 'url' => '/config/1/6/8/3/', + 'skip' => 'IP.Address.*?CH01', + }, + 'elsa-lancom-dsl10-ch02' => { + 'name' => 'ELSA LanCom DSL/10 DSL FW (isdn ch01)', + 'url' => '/config/1/6/8/3/', + 'skip' => 'IP.Address.*?CH02', + }, + 'linksys' => { + 'name' => 'Linksys FW', + 'url' => '/Status.htm', + 'skip' => 'WAN.*?Address', + }, + 'linksys-rv042-wan1' => { + 'name' => 'Linksys RV042 Dual Homed Router WAN Port 2', + 'url' => '/home.htm', + 'skip' => 'WAN1 IP', + }, + 'linksys-rv042-wan2' => { + 'name' => 'Linksys RV042 Dual Homed Router WAN Port 2', + 'url' => '/home.htm', + 'skip' => 'WAN2 IP', + }, + 'linksys-ver2' => { + 'name' => 'Linksys FW version 2', + 'url' => '/RouterStatus.htm', + 'skip' => 'WAN.*?Address', + }, + 'linksys-ver3' => { + 'name' => 'Linksys FW version 3', + 'url' => '/Status_Router.htm', + 'skip' => 'WAN.*?Address', + }, + 'linksys-wcg200' => { + 'name' => 'Linksys WCG200 FW', + 'url' => '/RgStatus.asp', + 'skip' => 'WAN.IP.*?Address', + }, + 'linksys-wrt854g' => { + 'name' => 'Linksys WRT854G FW', + 'url' => '/Status_Router.asp', + 'skip' => 'IP Address:', + }, + 'maxgate-ugate3x00' => { + 'name' => 'MaxGate UGATE-3x00 FW', + 'url' => '/Status.htm', + 'skip' => 'WAN.*?IP Address', + }, + 'netcomm-nb3' => { + 'name' => 'NetComm NB3', + 'url' => '/MainPage?id=6', + 'skip' => 'ppp-0', + }, + 'netgear-dg834g' => { + 'name' => 'netgear-dg834g', + 'url' => '/setup.cgi?next_file=s_status.htm&todo=cfg_init', + 'skip' => '', + }, + 'netgear-rp614' => { + 'name' => 'Netgear RP614 FW', + 'url' => '/sysstatus.html', + 'skip' => 'IP Address', + }, + 'netgear-rt3xx' => { + 'name' => 'Netgear FW', + 'url' => '/mtenSysStatus.html', + 'skip' => 'IP Address', + }, + 'netgear-wgt624' => { + 'name' => 'Netgear WGT624', + 'url' => '/RST_st_dhcp.htm', + 'skip' => 'IP Address', + }, + 'netgear-wpn824' => { + 'name' => 'Netgear WPN824 FW', + 'url' => '/RST_status.htm', + 'skip' => 'IP Address', + }, + 'netopia-r910' => { + 'name' => 'Netopia R910 FW', + 'url' => '/WanEvtLog', + 'skip' => 'local:', + }, + 'olitec-SX200' => { + 'name' => 'olitec-SX200', + 'url' => '/doc/wan.htm', + 'skip' => 'st_wan_ip[0] = "', + }, + 'rtp300' => { + 'name' => 'Linksys RTP300', + 'url' => '/cgi-bin/webcm?getpage=%2Fusr%2Fwww_safe%2Fhtml%2Fstatus%2FRouter.html', + 'skip' => 'Internet.*?IP Address', + }, + 'siemens-ss4200' => { + 'name' => 'Siemens SpeedStream 4200', + 'url' => '/summary.htm', + 'skip' => '', + }, + 'sitecom-dc202' => { + 'name' => 'Sitecom DC-202 FW', + 'url' => '/status.htm', + 'skip' => 'Internet IP Address', + }, + 'smc-barricade' => { + 'name' => 'SMC Barricade FW', + 'url' => '/status.htm', + 'skip' => 'IP Address', + }, + 'smc-barricade-7004vbr' => { + 'name' => 'SMC Barricade FW (7004VBR model config)', + 'url' => '/status_main.stm', + 'skip' => 'var wan_ip=', + }, + 'smc-barricade-7401bra' => { + 'name' => 'SMC Barricade 7401BRA FW', + 'url' => '/admin/wan1.htm', + 'skip' => 'IP Address', + }, + 'smc-barricade-alt' => { + 'name' => 'SMC Barricade FW (alternate config)', + 'url' => '/status.HTM', + 'skip' => 'WAN IP', + }, + 'sohoware-nbg800' => { + 'name' => 'SOHOWare BroadGuard NBG800', + 'url' => '/status.htm', + 'skip' => 'Internet IP', + }, + 'sveasoft' => { + 'name' => 'Sveasoft WRT54G/WRT54GS', + 'url' => '/Status_Router.asp', + 'skip' => 'var wan_ip', + }, + 'thomson-st536v6' => { + 'name' => 'Thomson SpeedTouch 536v6', + 'url' => '/cgi/b/is/', + 'skip' => 'IP Address', + }, + 'thomson-tg782' => { + 'name' => 'Thomson/Technicolor TG782', + 'url' => '/cgi/b/is/', + 'skip' => 'IP Address', + }, + 'vigor-2200usb' => { + 'name' => 'Vigor 2200 USB', + 'url' => '/doc/online.sht', + 'skip' => 'PPPoA', + }, + 'watchguard-edge-x' => { + 'name' => 'Watchguard Edge X FW', + 'url' => '/netstat.htm', + 'skip' => 'inet addr:', + }, + 'watchguard-soho' => { + 'name' => 'Watchguard SOHO FW', + 'url' => '/pubnet.htm', + 'skip' => 'NAME=IPAddress VALUE=', + }, + 'westell-6100' => { + 'name' => 'Westell C90-610015-06 DSL Router', + 'url' => '/advstat.htm', + 'skip' => 'IP.+?Address', + }, + 'xsense-aero' => { + 'name' => 'Xsense Aero', + 'url' => '/A_SysInfo.htm', + 'skip' => 'WAN.*?IP Address', + }, +); + +my %ip_strategies = ( + 'no' => ": deprecated, see 'usev4' and 'usev6'", + 'ip' => ": deprecated, see 'usev4' and 'usev6'", + 'web' => ": deprecated, see 'usev4' and 'usev6'", + 'fw' => ": deprecated, see 'usev4' and 'usev6'", + 'if' => ": deprecated, see 'usev4' and 'usev6'", + 'cmd' => ": deprecated, see 'usev4' and 'usev6'", + 'cisco' => ": deprecated, see 'usev4' and 'usev6'", + 'cisco-asa' => ": deprecated, see 'usev4' and 'usev6'", + map({ $_ => sprintf(": Built-in firewall %s deprecated, see 'usev4' and 'usev6'", + $builtinfw{$_}->{'name'}) } + keys(%builtinfw)), +); + +sub ip_strategies_usage { + return map({ sprintf(" -use=%-22s %s.", $_, $ip_strategies{$_}) } + ('ip', 'web', 'if', 'cmd', 'fw', sort('cisco', 'cisco-asa', keys(%builtinfw)))); +} + +my %ipv4_strategies = ( + 'disabled' => ": do not obtain an IPv4 address for this host", + 'ipv4' => ": obtain IPv4 from -ipv4 {address}", + 'webv4' => ": obtain IPv4 from an IP discovery page on the web", + 'ifv4' => ": obtain IPv4 from the -ifv4 {interface}", + 'cmdv4' => ": obtain IPv4 from the -cmdv4 {external-command}", + 'fwv4' => ": obtain IPv4 from the firewall specified by -fwv4 {type|address}", + 'ciscov4' => ": obtain IPv4 from Cisco FW at the -fwv4 {address}", + 'cisco-asav4' => ": obtain IPv4 from Cisco ASA at the -fwv4 {address}", + map { $_ => sprintf ": obtain IPv4 from %s at the -fwv4 {address}", $builtinfw{$_}->{'name'} } keys %builtinfw, +); +sub ipv4_strategies_usage { + return map { sprintf(" -usev4=%-22s %s.", $_, $ipv4_strategies{$_}) } sort keys %ipv4_strategies; +} + +my %ipv6_strategies = ( + 'no' => ": deprecated, use 'disabled'", + 'disabled' => ": do not obtain an IPv6 address for this host", + 'ip' => ": deprecated, use 'ipv6'", + 'ipv6' => ": obtain IPv6 from -ipv6 {address}", + 'web' => ": deprecated, use 'webv6'", + 'webv6' => ": obtain IPv6 from an IP discovery page on the web", + 'if' => ": deprecated, use 'ifv6'", + 'ifv6' => ": obtain IPv6 from the -if {interface}", + 'cmd' => ": deprecated, use 'cmdv6'", + 'cmdv6' => ": obtain IPv6 from the -cmdv6 {external-command}", + 'fwv6' => ": obtain IPv6 from the firewall specified by -fwv6 {type|address}", + 'ciscov6' => ": obtain IPv6 from Cisco FW at the -fwv6 {address}", + 'cisco-asav6' => ": obtain IPv6 from Cisco ASA at the -fwv6 {address}", + map { $_ => sprintf ": obtain IPv6 from %s at the -fwv6 {address}", $builtinfw{$_}->{'name'} } keys %builtinfw, +); +sub ipv6_strategies_usage { + return map { sprintf(" -usev6=%-22s %s.", $_, $ipv6_strategies{$_}) } sort keys %ipv6_strategies; +} + +sub setv { + return { + 'type' => shift, + 'required' => shift, + 'cache' => shift, + 'default' => shift, + 'minimum' => shift, + }; +} +my %variables = ( + 'global-defaults' => { + 'daemon' => setv(T_DELAY, 0, 0, $daemon_default, interval('60s')), + 'foreground' => setv(T_BOOL, 0, 0, 0, undef), + 'file' => setv(T_FILE, 0, 0, "$etc/$program.conf", undef), + 'cache' => setv(T_FILE, 0, 0, "$cachedir/$program.cache", undef), + 'pid' => setv(T_FILE, 0, 0, "", undef), + 'proxy' => setv(T_FQDNP, 0, 0, undef, undef), + 'protocol' => setv(T_PROTO, 0, 0, 'dyndns2', undef), + + 'use' => setv(T_USE, 0, 0, 'ip', undef), + 'usev4' => setv(T_USEV4, 0, 0, 'disabled', undef), + 'usev6' => setv(T_USEV6, 0, 0, 'disabled', undef), + 'ip' => setv(T_IP, 0, 0, undef, undef), + 'ipv4' => setv(T_IPV4, 0, 0, undef, undef), + 'ipv6' => setv(T_IPV6, 0, 0, undef, undef), + 'if' => setv(T_IF, 0, 0, 'ppp0', undef), + 'ifv4' => setv(T_IF, 0, 0, 'default', undef), + 'ifv6' => setv(T_IF, 0, 0, 'default', undef), + 'web' => setv(T_STRING,0, 0, 'dyndns', undef), + 'web-skip' => setv(T_STRING,1, 0, '', undef), + 'webv4' => setv(T_STRING,0, 0, 'googledomains', undef), + 'webv4-skip' => setv(T_STRING,1, 0, '', undef), + 'webv6' => setv(T_STRING,0, 0, 'googledomains', undef), + 'webv6-skip' => setv(T_STRING,1, 0, '', undef), + 'fw' => setv(T_ANY, 0, 0, '', undef), + 'fw-skip' => setv(T_STRING,1, 0, '', undef), + 'fwv4' => setv(T_ANY, 0, 0, '', undef), + 'fwv4-skip' => setv(T_STRING,1, 0, '', undef), + 'fwv6' => setv(T_ANY, 0, 0, '', undef), + 'fwv6-skip' => setv(T_STRING,1, 0, '', undef), + 'fw-login' => setv(T_LOGIN, 1, 0, '', undef), + 'fw-password' => setv(T_PASSWD,1, 0, '', undef), + 'cmd' => setv(T_PROG, 0, 0, '', undef), + 'cmd-skip' => setv(T_STRING,1, 0, '', undef), + 'cmdv4' => setv(T_PROG, 0, 0, '', undef), + 'cmdv6' => setv(T_PROG, 0, 0, '', undef), + + 'timeout' => setv(T_DELAY, 0, 0, interval('120s'), interval('120s')), + 'retry' => setv(T_BOOL, 0, 0, 0, undef), + 'force' => setv(T_BOOL, 0, 0, 0, undef), + 'ssl' => setv(T_BOOL, 0, 0, 0, undef), + 'curl' => setv(T_BOOL, 0, 0, 0, undef), + 'syslog' => setv(T_BOOL, 0, 0, 0, undef), + 'facility' => setv(T_STRING,0, 0, 'daemon', undef), + 'priority' => setv(T_STRING,0, 0, 'notice', undef), + 'mail' => setv(T_EMAIL, 0, 0, '', undef), + 'mail-failure' => setv(T_EMAIL, 0, 0, '', undef), + 'max-warn' => setv(T_NUMBER,0, 0, 1, undef), + + 'exec' => setv(T_BOOL, 0, 0, 1, undef), + 'debug' => setv(T_BOOL, 0, 0, 0, undef), + 'verbose' => setv(T_BOOL, 0, 0, 0, undef), + 'quiet' => setv(T_BOOL, 0, 0, 0, undef), + 'help' => setv(T_BOOL, 0, 0, 0, undef), + 'test' => setv(T_BOOL, 0, 0, 0, undef), + 'geturl' => setv(T_STRING,0, 0, '', undef), + + 'postscript' => setv(T_POSTS, 0, 0, '', undef), + 'ssl_ca_dir' => setv(T_FILE, 0, 0, undef, undef), + 'ssl_ca_file' => setv(T_FILE, 0, 0, undef, undef), + }, + 'service-common-defaults' => { + 'server' => setv(T_FQDNP, 1, 0, 'members.dyndns.org', undef), + 'login' => setv(T_LOGIN, 1, 0, '', undef), + 'password' => setv(T_PASSWD,1, 0, '', undef), + 'host' => setv(T_STRING,1, 1, '', undef), + + 'use' => setv(T_USE, 0, 0, 'ip', undef), + 'if' => setv(T_IF, 0, 0, 'ppp0', undef), + 'web' => setv(T_STRING,0, 0, 'dyndns', undef), + 'web-skip' => setv(T_STRING,0, 0, '', undef), + 'web-ssl-validate' => setv(T_BOOL, 0, 0, 1, undef), + 'fw' => setv(T_ANY, 0, 0, '', undef), + 'fw-skip' => setv(T_STRING,0, 0, '', undef), + 'fw-login' => setv(T_LOGIN, 0, 0, '', undef), + 'fw-password' => setv(T_PASSWD,0, 0, '', undef), + 'fw-ssl-validate' => setv(T_BOOL, 0, 0, 1, undef), + 'cmd' => setv(T_PROG, 0, 0, '', undef), + 'cmd-skip' => setv(T_STRING,0, 0, '', undef), + 'ip' => setv(T_IP, 0, 1, undef, undef), #TODO remove from cache? + 'ipv4' => setv(T_IPV4, 0, 1, undef, undef), + 'ipv6' => setv(T_IPV6, 0, 1, undef, undef), + 'wtime' => setv(T_DELAY, 0, 1, 0, interval('30s')), + 'mtime' => setv(T_NUMBER,0, 1, 0, undef), + 'atime' => setv(T_NUMBER,0, 1, 0, undef), + 'status' => setv(T_ANY, 0, 1, '', undef), #TODO remove from cache? + 'status-ipv4' => setv(T_ANY, 0, 1, '', undef), + 'status-ipv6' => setv(T_ANY, 0, 1, '', undef), + 'min-interval' => setv(T_DELAY, 0, 0, interval('30s'), 0), + 'max-interval' => setv(T_DELAY, 0, 0, interval('25d'), 0), + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + + 'warned-min-interval' => setv(T_ANY, 0, 1, 0, undef), + 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, undef), + }, + 'dyndns-common-defaults' => { + 'backupmx' => setv(T_BOOL, 0, 1, 0, undef), + 'mx' => setv(T_OFQDN, 0, 1, '', undef), + 'static' => setv(T_BOOL, 0, 1, 0, undef), + 'wildcard' => setv(T_BOOL, 0, 1, 0, undef), + }, + 'keysystems-common-defaults' => { + 'server' => setv(T_FQDNP, 1, 0, 1, 'dynamicdns.key-systems.net', undef), + 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), + }, + 'dnsexit-common-defaults' => { + 'ssl' => setv(T_BOOL, 0, 0, 1, undef), + 'server' => setv(T_FQDNP, 1, 0, 'update.dnsexit.com', undef), + 'script' => setv(T_STRING, 0, 1, '/RemoteUpdate.sv', undef), + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('8m'), 0), + }, +); +my %services = ( + '1984' => { + 'updateable' => undef, + 'update' => \&nic_1984_update, + 'examples' => \&nic_1984_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 0, 0, 'unused', undef), + 'server' => setv(T_FQDNP, 1, 0, 'api.1984.is', undef), + }, + }, + 'changeip' => { + 'updateable' => undef, + 'update' => \&nic_changeip_update, + 'examples' => \&nic_changeip_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), + 'server' => setv(T_FQDNP, 1, 0, 'nic.changeip.com', undef), + }, + }, + 'cloudflare' => { + 'updateable' => undef, + 'update' => \&nic_cloudflare_update, + 'examples' => \&nic_cloudflare_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'backupmx' => setv(T_BOOL, 0, 1, 0, undef), + 'login' => setv(T_LOGIN, 0, 0, 'token', undef), + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'mx' => setv(T_OFQDN, 0, 1, '', undef), + 'server' => setv(T_FQDNP, 1, 0, 'api.cloudflare.com/client/v4', undef), + 'static' => setv(T_BOOL, 0, 1, 0, undef), + 'ttl' => setv(T_NUMBER, 1, 0, 1, undef), + 'wildcard' => setv(T_BOOL, 0, 1, 0, undef), + 'zone' => setv(T_FQDN, 1, 0, '', undef), + }, + }, + 'cloudns' => { + 'updateable' => undef, + 'update' => \&nic_cloudns_update, + 'examples' => \&nic_cloudns_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'dynurl' => setv(T_STRING, 1, 0, undef, undef), + # nic_updateable() assumes that every service uses a username and password but that is + # not true for CloudNS. Silence warnings by redefining the username and password + # variables as non-required with a non-empty default. + 'login' => setv(T_STRING, 0, 0, 'unused', undef), + 'password' => setv(T_STRING, 0, 0, 'unused', undef), + }, + }, + 'dinahosting' => { + 'updateable' => undef, + 'update' => \&nic_dinahosting_update, + 'examples' => \&nic_dinahosting_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('8m'), 0), + 'script' => setv(T_STRING, 0, 1, '/special/api.php', undef), + 'server' => setv(T_FQDNP, 1, 0, 'dinahosting.com', undef), + }, + }, + 'dnsmadeeasy' => { + 'updateable' => undef, + 'update' => \&nic_dnsmadeeasy_update, + 'examples' => \&nic_dnsmadeeasy_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'script' => setv(T_STRING, 1, 1, '/servlet/updateip', undef), + 'server' => setv(T_FQDNP, 1, 0, 'cp.dnsmadeeasy.com', undef), + }, + }, + 'dondominio' => { + 'updateable' => undef, + 'update' => \&nic_dondominio_update, + 'examples' => \&nic_dondominio_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'server' => setv(T_FQDNP, 1, 0, 'dondns.dondominio.com', undef), + }, + }, + 'dslreports1' => { + 'updateable' => undef, + 'update' => \&nic_dslreports1_update, + 'examples' => \&nic_dslreports1_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'server' => setv(T_FQDNP, 1, 0, 'www.dslreports.com', undef), + 'host' => setv(T_NUMBER, 1, 1, 0, undef), + }, + }, + 'duckdns' => { + 'updateable' => undef, + 'update' => \&nic_duckdns_update, + 'examples' => \&nic_duckdns_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 0, 0, 'unused', undef), + 'server' => setv(T_FQDNP, 1, 0, 'www.duckdns.org', undef), + }, + }, + 'dyndns1' => { + 'updateable' => \&nic_dyndns2_updateable, + 'update' => \&nic_dyndns1_update, + 'examples' => \&nic_dyndns1_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + %{$variables{'dyndns-common-defaults'}}, + }, + }, + 'dyndns2' => { + 'updateable' => \&nic_dyndns2_updateable, + 'update' => \&nic_dyndns2_update, + 'examples' => \&nic_dyndns2_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + %{$variables{'dyndns-common-defaults'}}, + 'custom' => setv(T_BOOL, 0, 1, 0, undef), + 'script' => setv(T_STRING, 1, 1, '/nic/update', undef), + }, + }, + 'easydns' => { + 'updateable' => undef, + 'update' => \&nic_easydns_update, + 'examples' => \&nic_easydns_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'backupmx' => setv(T_BOOL, 0, 1, 0, undef), + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'mx' => setv(T_OFQDN, 0, 1, '', undef), + 'server' => setv(T_FQDNP, 1, 0, 'api.cp.easydns.com', undef), + 'script' => setv(T_STRING, 1, 1, '/dyn/generic.php', undef), + 'wildcard' => setv(T_BOOL, 0, 1, 0, undef), + }, + }, + 'freedns' => { + 'updateable' => undef, + 'update' => \&nic_freedns_update, + 'examples' => \&nic_freedns_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), + 'server' => setv(T_FQDNP, 1, 0, 'freedns.afraid.org', undef), + }, + }, + 'freemyip' => { + 'updateable' => undef, + 'update' => \&nic_freemyip_update, + 'examples' => \&nic_freemyip_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 0, 0, 'unused', undef), + 'server' => setv(T_FQDNP, 1, 0, 'freemyip.com', undef), + }, + }, + 'gandi' => { + 'updateable' => undef, + 'update' => \&nic_gandi_update, + 'examples' => \&nic_gandi_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), + 'server' => setv(T_FQDNP, 1, 0, 'api.gandi.net', undef), + 'script' => setv(T_STRING, 1, 1, '/v5', undef), + 'ttl' => setv(T_DELAY, 0, 0, undef, interval('5m')), + 'zone' => setv(T_FQDN, 1, 0, undef, undef), + # Unused variables. + 'login' => setv(T_STRING, 0, 0, 'unused', undef), + } + }, + 'godaddy' => { + 'updateable' => undef, + 'update' => \&nic_godaddy_update, + 'examples' => \&nic_godaddy_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'server' => setv(T_FQDNP, 1, 0, 'api.godaddy.com/v1/domains', undef), + 'ttl' => setv(T_NUMBER, 1, 0, 600, undef), + 'zone' => setv(T_FQDN, 1, 0, '', undef), + }, + }, + 'googledomains' => { + 'updateable' => undef, + 'update' => \&nic_googledomains_update, + 'examples' => \&nic_googledomains_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'server' => setv(T_FQDNP, 1, 0, 'domains.google.com', undef), + }, + }, + 'hetzner' => { + 'updateable' => undef, + 'update' => \&nic_hetzner_update, + 'examples' => \&nic_hetzner_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 0, 0, 'token', undef), + 'min-interval' => setv(T_DELAY, 0, 0, interval('1m'), 0), + 'server' => setv(T_FQDNP, 1, 0, 'dns.hetzner.com/api/v1', undef), + 'ttl' => setv(T_NUMBER, 0, 0, 60, 60), + 'zone' => setv(T_FQDN, 1, 0, '', undef), + }, + }, + 'namecheap' => { + 'updateable' => undef, + 'update' => \&nic_namecheap_update, + 'examples' => \&nic_namecheap_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), + 'server' => setv(T_FQDNP, 1, 0, 'dynamicdns.park-your-domain.com', undef), + }, + }, + 'nfsn' => { + 'updateable' => undef, + 'update' => \&nic_nfsn_update, + 'examples' => \&nic_nfsn_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min_interval' => setv(T_FQDNP, 0, 0, 0, interval('5m')), + 'server' => setv(T_FQDNP, 1, 0, 'api.nearlyfreespeech.net', undef), + 'ttl' => setv(T_NUMBER, 1, 0, 300, undef), + 'zone' => setv(T_FQDN, 1, 0, undef, undef), + }, + }, + 'njalla' => { + 'updateable' => undef, + 'update' => \&nic_njalla_update, + 'examples' => \&nic_njalla_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_STRING, 0, 0, 'unused', undef), + 'server' => setv(T_FQDNP, 1, 0, 'njal.la', undef), + 'quietreply' => setv(T_BOOL, 0, 1, 0, undef) + }, + }, + 'noip' => { + 'updateable' => undef, + 'update' => \&nic_noip_update, + 'examples' => \&nic_noip_examples, + 'variables' => { + 'atime' => setv(T_NUMBER, 0, 1, 0, undef), + 'custom' => setv(T_BOOL, 0, 1, 0, undef), + 'host' => setv(T_STRING, 1, 1, '', undef), + 'ip' => setv(T_IP, 0, 1, undef, undef), + 'login' => setv(T_LOGIN, 1, 0, '', undef), + 'max-interval' => setv(T_DELAY, 0, 0, interval('25d'), 0), + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'min-interval' => setv(T_DELAY, 0, 0, interval('30s'), 0), + 'mtime' => setv(T_NUMBER, 0, 1, 0, undef), + 'password' => setv(T_PASSWD, 1, 0, '', undef), + 'server' => setv(T_FQDNP, 1, 0, 'dynupdate.no-ip.com', undef), + 'static' => setv(T_BOOL, 0, 1, 0, undef), + 'status' => setv(T_ANY, 0, 1, '', undef), + 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, undef), + 'warned-min-interval' => setv(T_ANY, 0, 1, 0, undef), + 'wtime' => setv(T_DELAY, 0, 1, 0, interval('30s')), + }, + }, + 'nsupdate' => { + 'updateable' => undef, + 'update' => \&nic_nsupdate_update, + 'examples' => \&nic_nsupdate_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 1, 0, '/usr/bin/nsupdate', undef), + 'tcp' => setv(T_BOOL, 0, 1, 0, undef), + 'ttl' => setv(T_NUMBER, 0, 1, 600, undef), + 'zone' => setv(T_STRING, 1, 1, '', undef), + }, + }, + 'ovh' => { + 'updateable' => undef, + 'update' => \&nic_ovh_update, + 'examples' => \&nic_ovh_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'login' => setv(T_LOGIN, 1, 0, '', undef), + 'password' => setv(T_PASSWD, 1, 0, '', undef), + 'script' => setv(T_STRING, 1, 1, '/nic/update', undef), + 'server' => setv(T_FQDNP, 1, 0, 'www.ovh.com', undef), + }, + }, + 'sitelutions' => { + 'updateable' => undef, + 'update' => \&nic_sitelutions_update, + 'examples' => \&nic_sitelutions_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'server' => setv(T_FQDNP, 1, 0, 'www.sitelutions.com', undef), + 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), + }, + }, + 'woima' => { + 'updateable' => undef, + 'update' => \&nic_woima_update, + 'examples' => \&nic_woima_examples, + 'variables' => { + 'atime' => setv(T_NUMBER, 0, 1, 0, undef), + 'backupmx' => setv(T_BOOL, 0, 1, 0, undef), + 'custom' => setv(T_BOOL, 0, 1, 0, undef), + 'ip' => setv(T_IP, 0, 1, undef, undef), + 'login' => setv(T_LOGIN, 1, 0, '', undef), + 'max-interval' => setv(T_DELAY, 0, 0, interval('25d'), 0), + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'min-interval' => setv(T_DELAY, 0, 0, interval('30s'), 0), + 'mtime' => setv(T_NUMBER, 0, 1, 0, undef), + 'mx' => setv(T_OFQDN, 0, 1, '', undef), + 'password' => setv(T_PASSWD, 1, 0, '', undef), + 'script' => setv(T_STRING, 1, 1, '/nic/update', undef), + 'server' => setv(T_FQDNP, 1, 0, 'dyn.woima.fi', undef), + 'static' => setv(T_BOOL, 0, 1, 0, undef), + 'status' => setv(T_ANY, 0, 1, '', undef), + 'warned-min-error-interval' => setv(T_ANY, 0, 1, 0, undef), + 'warned-min-interval' => setv(T_ANY, 0, 1, 0, undef), + 'wildcard' => setv(T_BOOL, 0, 1, 0, undef), + 'wtime' => setv(T_DELAY, 0, 1, 0, interval('30s')), + }, + }, + 'yandex' => { + 'updateable' => undef, + 'update' => \&nic_yandex_update, + 'examples' => \&nic_yandex_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'server' => setv(T_FQDNP, 1, 0, 'pddimp.yandex.ru', undef), + }, + }, + 'zoneedit1' => { + 'updateable' => undef, + 'update' => \&nic_zoneedit1_update, + 'examples' => \&nic_zoneedit1_examples, + 'variables' => { + %{$variables{'service-common-defaults'}}, + 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), + 'server' => setv(T_FQDNP, 1, 0, 'dynamic.zoneedit.com', undef), + 'zone' => setv(T_OFQDN, 0, 0, undef, undef), + }, + }, + 'keysystems' => { + 'updateable' => undef, + 'update' => \&nic_keysystems_update, + 'examples' => \&nic_keysystems_examples, + 'variables' => merge( + $variables{'keysystems-common-defaults'}, + $variables{'service-common-defaults'}, + ), + }, + 'dnsexit' => { + 'updateable' => undef, + 'update' => \&nic_dnsexit_update, + 'examples' => \&nic_dnsexit_examples, + 'variables' => merge( + $variables{'dnsexit-common-defaults'}, + $variables{'service-common-defaults'}, + ), + }, +); +$variables{'merged'} = { + map({ %{$services{$_}{'variables'}} } keys(%services)), + %{$variables{'dyndns-common-defaults'}}, + %{$variables{'service-common-defaults'}}, + %{$variables{'global-defaults'}}, +}; + +# This will hold the processed args. +my %opt = (); +my $deprecated_handler = sub { warning("'-$_[0]' is deprecated and does nothing"); }; +$opt{'fw-banlocal'} = $deprecated_handler; +$opt{'if-skip'} = $deprecated_handler; +$opt{'list-devices'} = sub { + printf("%s %s\n", $_, $builtinfw{$_}{name}) for sort(keys(%builtinfw)); + exit(0); +}; +$opt{'list-protocols'} = sub { + printf("%s\n", $_) for sort(keys(%services)); + exit(0); +}; +$opt{'list-web-services'} = sub { + printf("%s %s\n", $_, $builtinweb{$_}{url}) for sort(keys(%builtinweb)); + exit(0); +}; + +my @opt = ( + "usage: ${program} [options]", + "options are:", + ["daemon", "=s", "-daemon : run as a daemon, specify as an interval"], + ["foreground", "!", "-foreground : do not fork"], + ["proxy", "=s", "-proxy : use as the HTTP proxy"], + ["server", "=s", "-server : update DNS information on "], + ["protocol", "=s", "-protocol : update protocol used"], + ["list-protocols", "", "-list-protocols : print a machine-readable list of supported update protocols and exit. Format: one per line"], + ["file", "=s", "-file : load configuration information from "], + ["cache", "=s", "-cache : record address used in "], + ["pid", "=s", "-pid : record process id in if daemonized"], + "", + ["use", "=s", "-use : deprecated, see 'usev4' and 'usev6'"], + &ip_strategies_usage(), + [ "usev4", "=s", "-usev4 : how the should IPv4 address be obtained."], + &ipv4_strategies_usage(), + [ "usev6", "=s", "-usev6 : how the should IPv6 address be obtained."], + &ipv6_strategies_usage(), + "", + " Options that apply to 'use=ip':", + ["ip", "=s", "-ip
: deprecated, use 'ipv4' or 'ipv6'"], + ["ipv4", "=s", "-ipv4
: set the IPv4 address to
"], + ["ipv6", "=s", "-ipv6
: set the IPv6 address to
"], + "", + " Options that apply to 'use=if':", + ["if", "=s", "-if : deprecated, use 'ifv4' or 'ifv6'"], + ["ifv4", "=s", "-ifv4 : obtain IPv4 address from "], + ["ifv6", "=s", "-ifv6 : obtain IPv6 address from "], + "", + " Options that apply to 'use=web':", + ["web", "=s", "-web | : deprecated, use 'webv4' or 'webv6'"], + ["web-skip", "=s", "-web-skip : deprecated, use 'webv4-skip' or 'webv6-skip'"], + ["webv4", "=s", "-webv4 |: obtain IPv4 address from a web-based IP discovery service, either a known or a custom "], + ["webv4-skip", "=s", "-webv4-skip : skip any IP addresses before in the output of 'ip address show dev ' (or 'ifconfig ')"], + ["webv6", "=s", "-webv6 |: obtain IPv6 address from a web-based IP discovery service, either a known or a custom "], + ["webv6-skip", "=s", "-webv6-skip : skip any IP addresses before in the output of 'ip address show dev ' (or 'ifconfig ')"], + ["list-web-services", "", "-list-web-services : print a machine-readable list of web-based IP discovery services for use with 'web=' and exit. Format: one service per line, each line has the form ' '"], + "", + " Options that apply to 'use=fw' and 'use=':", + ["fw", "=s", "-fw
| : deprecated, use 'fwv4' or 'fwv6'"], + ["fw-skip", "=s", "-fw-skip : deprecated, use 'fwv4-skip' or 'fwv6-skip'"], + ["fwv4", "=s", "-fwv4
| : obtain IPv4 address from device with IP address
or URL "], + ["fwv4-skip", "=s", "-fwv4-skip : skip any IP addresses before in the text returned from the device"], + ["fwv6", "=s", "-fwv6
| : obtain IPv6 address from device with IP address
or URL "], + ["fwv6-skip", "=s", "-fwv6-skip : skip any IP addresses before in the text returned from the device"], + ["fw-login", "=s", "-fw-login : use when getting the IP from the device"], + ["fw-password", "=s", "-fw-password : use password when getting the IP from the device"], + ["list-devices", "", "-list-devices : print a machine-readable list of supported firewall/router devices and exit. Format: one device per line, each line has the form ' '"], + "", + " Options that apply to 'use=cmd':", + ["cmd", "=s", "-cmd : deprecated, use 'cmdv4' or 'cmdv6'"], + ["cmd-skip", "=s", "-cmd-skip : deprecated, filter in program wrapper script"], + ["cmdv4", "=s", "-cmdv4 : obtain IPv4 address from the output of "], + ["cmdv6", "=s", "-cmdv6 : obtain IPv6 address from the output of "], + "", + ["login", "=s", "-login : log in to the dynamic DNS service as "], + ["password", "=s", "-password : log in to the dynamic DNS service with password "], + ["host", "=s", "-host : update DNS information for "], + "", + ["options", "=s", "-options =[,=,...]\n : optional per-service arguments (see below)"], + "", + ["ssl", "!", "-{no}ssl : do updates over encrypted SSL connection"], + ["ssl_ca_dir", "=s", "-ssl_ca_dir : look in for certificates of trusted certificate authorities (default: auto-detect)"], + ["ssl_ca_file", "=s", "-ssl_ca_file : look at for certificates of trusted certificate authorities (default: auto-detect)"], + ["fw-ssl-validate", "!", "-{no}fw-ssl-validate : Validate SSL certificate when retrieving IP address from firewall"], + ["web-ssl-validate", "!","-{no}web-ssl-validate : Validate SSL certificate when retrieving IP address from web"], + ["curl", "!", "-{no}curl : use curl for network connections"], + ["retry", "!", "-{no}retry : retry failed updates"], + ["force", "!", "-{no}force : force an update even if the update may be unnecessary"], + ["timeout", "=i", "-timeout : when fetching a URL, wait at most seconds for a response"], + ["syslog", "!", "-{no}syslog : log messages to syslog"], + ["facility", "=s", "-facility : log messages to syslog to facility "], + ["priority", "=s", "-priority : log messages to syslog with priority "], + ["max-warn", "=i", "-max-warn : log at most warning messages for undefined IP address"], + ["mail", "=s", "-mail
: e-mail messages to
"], + ["mail-failure", "=s", "-mail-failure : e-mail messages for failed updates to "], + ["exec", "!", "-{no}exec : do {not} execute; just show what would be done"], + ["debug", "!", "-{no}debug : print {no} debugging information"], + ["verbose", "!", "-{no}verbose : print {no} verbose information"], + ["quiet", "!", "-{no}quiet : print {no} messages for unnecessary updates"], + ["help", "", "-help : display this message and exit"], + ["postscript", "", "-postscript : script to run after updating ddclient, has new IP as param"], + ["query", "!", "-{no}query : print {no} ip addresses and exit"], + ["fw-banlocal", "!", ""], ## deprecated + ["if-skip", "=s", ""], ## deprecated + ["test", "!", ""], ## hidden + ["geturl", "=s", ""], ## hidden + "", + nic_examples(), + "$program version $version, ", + " originally written by Paul Burry, paul+ddclient\@burry.ca", + " project now maintained on https://github.com/ddclient/ddclient" +); + +sub main { + ## process args + my $opt_usage = process_args(@opt); + $saved_cache = ''; + %saved_opt = %opt; + $result = 'OK'; + + test_geturl(opt('geturl')) if opt('geturl'); + + if (opt('help')) { + printf "%s\n", $opt_usage; + exit 0; + } + + ## read config file because 'daemon' mode may be defined there. + read_config($opt{'file'} // default('file'), \%config, \%globals); + init_config(); + test_possible_ip() if opt('query'); + + my $caught_hup = 0; + my $caught_term = 0; + my $caught_int = 0; + $SIG{'HUP'} = sub { $caught_hup = 1; }; + $SIG{'TERM'} = sub { $caught_term = 1; }; + $SIG{'INT'} = sub { $caught_int = 1; }; + # don't fork() if foreground + if (opt('foreground')) { + ; + } elsif (opt('daemon')) { + $SIG{'CHLD'} = 'IGNORE'; + my $pid = fork; + if ($pid < 0) { + print STDERR "${program}: can not fork ($!)\n"; + exit -1; + } elsif ($pid) { + exit 0; + } + $SIG{'CHLD'} = 'DEFAULT'; + open(STDOUT, ">/dev/null"); + open(STDERR, ">/dev/null"); + open(STDIN, " 0) && !$caught_hup && !$caught_term && !$caught_int) { + my $delay = $left > 10 ? 10 : $left; + + $0 = sprintf("%s - sleeping for %s seconds", $program, $left); + $left -= sleep $delay; + # preventing deep sleep - see [bugs:#46] + if ($left > $daemon) { + $left = $daemon; + } + } + $caught_hup = 0; + $result = 0; + + } elsif (!scalar(%config)) { + warning("no hosts to update.") unless !opt('quiet') || opt('verbose') || !$daemon; + $result = 1; + + } else { + $result = $result eq 'OK' ? 0 : 1; + } + } while ($daemon && !$result && !$caught_term && !$caught_int); + + warning("caught SIGINT; exiting") if $caught_int; + unlink_pid(); + sendmail(); + + exit($result); +} + +###################################################################### +## runpostscript +###################################################################### + +sub runpostscript { + my ($ip) = @_; + + if (defined $globals{postscript}) { + if (-x $globals{postscript}) { + system("$globals{postscript} $ip &"); + } else { + warning("Can not execute post script: %s", $globals{postscript}); + } + } +} + +###################################################################### +## update_nics +###################################################################### +sub update_nics { + my %examined = (); + my %iplist = (); + my %ipv4list = (); + my %ipv6list = (); + + foreach my $s (sort keys %services) { + my (@hosts, %ipsv4, %ipsv6) = (); + my $updateable = $services{$s}{'updateable'}; + my $update = $services{$s}{'update'}; + + foreach my $h (sort keys %config) { + next if $config{$h}{'protocol'} ne lc($s); + $examined{$h} = 1; + # we only do this once per 'use' and argument combination + my $use = opt('use', $h) // 'disabled'; + my $usev4 = opt('usev4', $h) // 'disabled'; + my $usev6 = opt('usev6', $h) // 'disabled'; + $use = 'disabled' if ($use eq 'no'); # backward compatibility + $usev6 = 'disabled' if ($usev6 eq 'no'); # backward compatibility + my $arg_ip = opt('ip', $h) // ''; + my $arg_ipv4 = opt('ipv4', $h) // ''; + my $arg_ipv6 = opt('ipv6', $h) // ''; + my $arg_fw = opt('fw', $h) // ''; + my $arg_fwv4 = opt('fwv4', $h) // ''; + my $arg_fwv6 = opt('fwv6', $h) // ''; + my $arg_if = opt('if', $h) // ''; + my $arg_ifv4 = opt('ifv4', $h) // ''; + my $arg_ifv6 = opt('ifv6', $h) // ''; + my $arg_web = opt('web', $h) // ''; + my $arg_webv4 = opt('webv4', $h) // ''; + my $arg_webv6 = opt('webv6', $h) // ''; + my $arg_cmd = opt('cmd', $h) // ''; + my $arg_cmdv4 = opt('cmdv4', $h) // ''; + my $arg_cmdv6 = opt('cmdv6', $h) // ''; + my $ip = undef; + my $ipv4 = undef; + my $ipv6 = undef; + + if ($use ne 'disabled') { + if (exists $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}) { + # If we have already done a get_ip() for this, don't do it again. + $ip = $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}; + } else { + # Else need to find the IP address... + $ip = get_ip($use, $h); + if (is_ipv4($ip) || is_ipv6($ip)) { + # And if it is valid, remember it... + $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd} = $ip; + } else { + warning("%s: unable to determine IP address with strategy use=%s", $h, $use) + if !$daemon || opt('verbose'); + } + } + # And remember it as the IP address we want to send to the DNS service. + $config{$h}{'wantip'} = $ip; + } + + if ($usev4 ne 'disabled') { + if (exists $ipv4list{$usev4}{$arg_ipv4}{$arg_fwv4}{$arg_ifv4}{$arg_webv4}{$arg_cmdv4}) { + # If we have already done a get_ipv4() for this, don't do it again. + $ipv4 = $ipv4list{$usev4}{$arg_ipv4}{$arg_fwv4}{$arg_ifv4}{$arg_webv4}{$arg_cmdv4}; + } else { + # Else need to find the IPv4 address... + $ipv4 = get_ipv4($usev4, $h); + if (is_ipv4($ipv4)) { + # And if it is valid, remember it... + $ipv4list{$usev4}{$arg_ipv4}{$arg_fwv4}{$arg_ifv4}{$arg_webv4}{$arg_cmdv4} = $ipv4; + } else { + warning("%s: unable to determine IPv4 address with strategy usev4=%s", $h, $usev4) + if !$daemon || opt('verbose'); + } + } + # And remember it as the IPv4 address we want to send to the DNS service. + $config{$h}{'wantipv4'} = $ipv4; + } + + if ($usev6 ne 'disabled') { + if (exists $ipv6list{$usev6}{$arg_ipv6}{$arg_fwv6}{$arg_ifv6}{$arg_webv6}{$arg_cmdv6}) { + # If we have already done a get_ipv6() for this, don't do it again. + $ipv6 = $ipv6list{$usev6}{$arg_ipv6}{$arg_fwv6}{$arg_ifv6}{$arg_webv6}{$arg_cmdv6}; + } else { + # Else need to find the IPv6 address... + $ipv6 = get_ipv6($usev6, $h); + if (is_ipv6($ipv6)) { + # And if it is valid, remember it... + $ipv6list{$usev6}{$arg_ipv6}{$arg_fwv6}{$arg_ifv6}{$arg_webv6}{$arg_cmdv6} = $ipv6; + } else { + warning("%s: unable to determine IPv6 address with strategy usev6=%s", $h, $usev6) + if !$daemon || opt('verbose'); + } + } + # And remember it as the IP address we want to send to the DNS service. + $config{$h}{'wantipv6'} = $ipv6; + } + + # DNS service update functions should only have to handle 'wantipv4' and 'wantipv6' + $config{$h}{'wantipv4'} = $ipv4 = $ip if (!$ipv4 && is_ipv4($ip)); + $config{$h}{'wantipv6'} = $ipv6 = $ip if (!$ipv6 && is_ipv6($ip)); + # But we will set 'wantip' to the IPv4 so old functions continue to work until we update them all + $config{$h}{'wantip'} = $ipv4 if (!$ip && $ipv4); + + next if !nic_updateable($h, $updateable); + push @hosts, $h; + + $ipsv4{$ipv4} = $h if ($ipv4); + $ipsv6{$ipv6} = $h if ($ipv6); + } + if (@hosts) { + $0 = sprintf("%s - updating %s", $program, join(',', @hosts)); + &$update(@hosts); + runpostscript(join ' ', keys %ipsv4, keys %ipsv6); + } + } + foreach my $h (sort keys %config) { + if (!exists $examined{$h}) { + failed("%s was not updated because protocol %s is not supported.", + $h, $config{$h}{'protocol'} // ''); + } + } + write_cache(opt('cache')); +} + +###################################################################### +## unlink_pid() +###################################################################### +sub unlink_pid { + if (opt('pid') && opt('daemon')) { + unlink opt('pid'); + } +} + +###################################################################### +## write_pid() +###################################################################### +sub write_pid { + my $file = opt('pid'); + + if ($file && opt('daemon')) { + local *FD; + if (!open(FD, "> $file")) { + warning("Cannot create file '%s'. (%s)", $file, $!); + + } else { + printf FD "%s\n", $$; + close(FD); + } + } +} + +###################################################################### +## write_cache($file) +###################################################################### +sub write_cache { + my ($file) = @_; + + ## merge the updated host entries into the cache. + foreach my $h (keys %config) { + if (!exists $cache{$h} || $config{$h}{'update'}) { + map { defined($config{$h}{$_}) ? ($cache{$h}{$_} = $config{$h}{$_}) : () } @{$config{$h}{'cacheable'}}; + } else { + map { $cache{$h}{$_} = $config{$h}{$_} } qw(atime wtime status); + } + } + + ## construct the cache file. + my $cache = ""; + foreach my $h (sort keys %cache) { + my $opt = join(',', map { "$_=" . ($cache{$h}{$_} // '') } sort keys %{$cache{$h}}); + + $cache .= sprintf "%s%s%s\n", $opt, ($opt ? ' ' : ''), $h; + } + $file = '' if defined($saved_cache) && $cache eq $saved_cache; + + ## write the updates and other entries to the cache file. + if ($file) { + (undef, my $dir) = fileparse($file); + make_path($dir, { error => \my $err }) if !-d $dir; + if ($err && @$err) { + for my $diag (@$err) { + my ($f, $msg) = %$diag; + warning("Failed to create cache file directory: %s: %s", $f, $msg); + } + return; + } + + $saved_cache = undef; + local *FD; + if (!open(FD, ">", $file)) { + warning("Failed to create cache file %s: %s", $file, $!); + return; + } + printf FD "## %s-%s\n", $program, $version; + printf FD "## last updated at %s (%d)\n", prettytime($now), $now; + printf FD "%s", $cache; + + close(FD); + } +} +###################################################################### +## read_cache($file) - called before reading the .conf +###################################################################### +sub read_cache { + my $file = shift; + my $config = shift; + my $globals = {}; + + %{$config} = (); + ## read the cache file ignoring anything on the command-line. + if (-e $file) { + my %saved = %opt; + %opt = (); + $saved_cache = _read_config($config, $globals, "##\\s*$program-$version\\s*", $file); + %opt = %saved; + + foreach my $h (keys %cache) { + if (exists $config->{$h}) { + foreach (qw(atime mtime wtime ip status)) { + $config->{$h}{$_} = $cache{$h}{$_} if exists $cache{$h}{$_}; + } + } + } + } +} +###################################################################### +## parse_assignments(string) return (rest, %variables) +## parse_assignment(string) return (name, value, rest) +###################################################################### +sub parse_assignments { + my ($rest) = @_; + my %variables = (); + + while (1) { + (my $name, my $value, $rest) = parse_assignment($rest); + $rest =~ s/^[,\s]+//; + return ($rest, %variables) if !defined($name); + if ($name eq 'fw-banlocal' || $name eq 'if-skip') { + warning("'$name' is deprecated and does nothing"); + next; + } + $variables{$name} = $value; + } +} +sub parse_assignment { + my ($rest) = @_; + my ($name, $value); + my ($escape, $quote) = (0, ''); + + if ($rest =~ /^[,\s]*([a-z][0-9a-z_-]*)=(.*)/i) { + ($name, $rest, $value) = ($1, $2, ''); + + while (length(my $c = substr($rest, 0, 1))) { + if ($escape) { + $value .= $c; + $escape = 0; + } elsif ($c eq "\\") { + $escape = 1; + } elsif ($quote && $c eq $quote) { + $quote = ''; + } elsif (!$quote && $c =~ /[\'\"]/) { + $quote = $c; + } elsif (!$quote && $c =~ /^[\n\s,]/) { + # The terminating character is not consumed. + last; + } else { + $value .= $c; + } + $rest = substr($rest,1); + } + } + warning("assignment to '%s' ended with the escape character (\\)", $name) if $escape; + warning("assignment to '%s' ended with an unterminated quote (%s)", $name, $quote) if $quote; + return ($name, $value, $rest); +} +###################################################################### +## read_config +###################################################################### +sub read_config { + my ($file, $config, $globals) = @_; + _read_config($config, $globals, '', $file); +} +sub _read_config { + # Configuration line format after comment and continuation + # removal: + # + # [opt=value, ...] [host[, ...] [login [password]]] + # + # Details: + # - No whitespace is allowed around the '=' in opt=value. + # - An option name may only contain lowercase letters, numbers, + # underscore, and hyphen-minus, and must start with a letter. + # - A value or hostname is terminated by unquoted whitespace + # (including newline) or an unquoted comma followed by + # optional whitespace. + # - Values (but not hosts, login, or password) may contain + # quoted parts: + # - A backslash that itself is not quoted by another + # backslash quotes the next character. + # - An unquoted single quote quotes the subsequent + # non-backslash, non-newline characters until the next + # single quote. + # - An unquoted double quote quotes the subsequent + # non-backslash, non-newline characters until the next + # double quote. + # - login and password must not contain whitespace. + # - login must not start or end with a comma. + # - password must not start with a comma. + # - If no host is specified (either via a 'host=' option or + # after the options), the options are stored in %{$2}. + # Otherwise, the options are combined with the global values + # accumulated thus far and stored in $1->{$host} for each + # referenced host. + + my $config = shift; + my $globals = shift; + my $stamp = shift; + local $file = shift; + my %globals = (); + my %config = (); + my $content = ''; + + local *FD; + if (!open(FD, "< $file")) { + warning("Cannot open file '%s'. (%s)", $file, $!); + } + + # If file is owned by our effective uid, ensure that it has no access for group or others. + # Otherwise, require that it isn't writable when not owned by us. For example allow it to + # be owned by root:ddclient with mode 640. Always ensure that it is not accessible to others. + my ($dev, $ino, $mode, @statrest) = stat(FD); + if ($mode & 077 && -o FD) { + if (-f FD && (chmod 0600, $file)) { + warning("file $file must be accessible only by its owner (fixed)."); + } + warning("file $file must be accessible only by its owner."); + } elsif (! -o FD && -w FD) { + warning("file $file should be owned only by ddclient or not be writable."); + } + if ($mode & 07) { + warning("file $file must not be accessible by others."); + } + + local $lineno = 0; + my $continuation = ''; + my %passwords = (); + while () { + s/[\r\n]//g; + + $lineno++; + + ## check for the program version stamp + if (($. == 1) && $stamp && ($_ !~ /^$stamp$/i)) { + warning("program version mismatch; ignoring %s", $file); + last; + } + if (/\\\s+$/) { + warning("whitespace follows the \\ at the end-of-line.\nIf you meant to have a line continuation, remove the trailing whitespace."); + } + + $content .= "$_\n" unless /^#/; + + ## parsing passwords is special + if (/^([^#]*\s)?([^#]*?password\S*?)\s*=\s*('.*'|[^']\S*)(.*)/) { + my ($head, $key, $value, $tail) = ($1 // '', $2, $3, $4); + $value = $1 if $value =~ /^'(.*)'$/; + $passwords{$key} = $value; + $_ = "${head}${key}=dummy${tail}"; + } + + ## remove comments + s/#.*//; + + ## handle continuation lines + $_ = "$continuation$_"; + if (/\\$/) { + chop; + $continuation = $_; + next; + } + $continuation = ''; + + s/^\s+//; # remove leading white space + s/\s+$//; # remove trailing white space + s/\s+/ /g; # canonify + next if /^$/; + + my %locals; + ($_, %locals) = parse_assignments($_); + s/\s*,\s*/,/g; + my @args = split; + + ## verify that keywords are valid...and check the value + foreach my $k (keys %locals) { + $locals{$k} = $passwords{$k} if defined $passwords{$k}; + if (!exists $variables{'merged'}{$k}) { + warning("unrecognized keyword '%s' (ignored)", $k); + delete $locals{$k}; + } else { + my $def = $variables{'merged'}{$k}; + my $value = check_value($locals{$k}, $def); + if (!defined($value)) { + warning("Invalid Value for keyword '%s' = '%s'", $k, $locals{$k}); + delete $locals{$k}; + } else { $locals{$k} = $value; } + } + } + if (exists($locals{'host'})) { + $args[0] = @args ? "$args[0],$locals{host}" : "$locals{host}"; + } + ## accumulate globals + if ($#args < 0) { + map { $globals{$_} = $locals{$_} } keys %locals; + } + + ## process this host definition + if (@args) { + my ($host, $login, $password) = @args; + + ## add in any globals.. + %locals = %{merge(\%locals, \%globals)}; + + ## override login and password if specified the old way. + $locals{'login'} = $login if defined $login; + $locals{'password'} = $password if defined $password; + + ## allow {host} to be a comma separated list of hosts + foreach my $h (split_by_comma($host)) { + ## save a copy of the current globals + $config{$h} = { %locals }; + $config{$h}{'host'} = $h; + } + } + %passwords = (); + } + close(FD); + + warning("file ends while expecting a continuation line.") + if $continuation; + + %$globals = %globals; + %$config = %config; + + return $content; +} +###################################################################### +## init_config - +###################################################################### +sub init_config { + %opt = %saved_opt; + + ## + $opt{'quiet'} = 0 if opt('verbose'); + + ## infer the IP strategy if possible + if (!$opt{'use'}) { + $opt{'use'} = 'web' if ($opt{'web'}); + $opt{'use'} = 'if' if ($opt{'if'}); + $opt{'use'} = 'ip' if ($opt{'ip'}); + } + ## infer the IPv4 strategy if possible + if (!$opt{'usev4'}) { + $opt{'usev4'} = 'webv4' if ($opt{'webv4'}); + $opt{'usev4'} = 'ifv4' if ($opt{'ifv4'}); + $opt{'usev4'} = 'ipv4' if ($opt{'ipv4'}); + } + ## infer the IPv6 strategy if possible + if (!$opt{'usev6'}) { + $opt{'usev6'} = 'webv6' if ($opt{'webv6'}); + $opt{'usev6'} = 'ifv6' if ($opt{'ifv6'}); + $opt{'usev6'} = 'ipv6' if ($opt{'ipv6'}); + } + + ## sanity check + $opt{'max-interval'} = min(interval(opt('max-interval')), interval(default('max-interval'))); + $opt{'min-interval'} = max(interval(opt('min-interval')), interval(default('min-interval'))); + $opt{'min-error-interval'} = max(interval(opt('min-error-interval')), interval(default('min-error-interval'))); + + $opt{'timeout'} = 0 if opt('timeout') < 0; + + ## parse an interval expression (such as '5m') into number of seconds + $opt{'daemon'} = interval(opt('daemon')) if defined($opt{'daemon'}); + ## make sure the interval isn't too short + $opt{'daemon'} = minimum('daemon') if opt('daemon') > 0 && opt('daemon') < minimum('daemon'); + + ## define or modify host options specified on the command-line + if (exists $opt{'options'} && defined $opt{'options'}) { + ## collect cmdline configuration options. + my %options = (); + foreach my $opt (split_by_comma($opt{'options'})) { + my ($name, $var) = split /\s*=\s*/, $opt; + if ($name eq 'fw-banlocal' || $name eq 'if-skip') { + warning("'$name' is deprecated and does nothing"); + next; + } + $options{$name} = $var; + } + ## determine hosts specified with -host + my @hosts = (); + if (exists $opt{'host'}) { + foreach my $h (split_by_comma($opt{'host'})) { + push @hosts, $h; + } + } + ## and those in -options=... + if (exists $options{'host'}) { + foreach my $h (split_by_comma($options{'host'})) { + push @hosts, $h; + } + delete $options{'host'}; + } + ## merge options into host definitions or globals + if (@hosts) { + foreach my $h (@hosts) { + $config{$h} = merge(\%options, $config{$h}); + } + $opt{'host'} = join(',', @hosts); + } else { + %globals = %{merge(\%options, \%globals)}; + } + } + + ## override global options with those on the command-line. + foreach my $o (keys %opt) { + if (defined $opt{$o} && exists $variables{'global-defaults'}{$o}) { + $globals{$o} = $opt{$o}; + } + } + + ## sanity check + if (defined $opt{'host'} && defined $opt{'retry'}) { + fatal("options -retry and -host (or -option host=..) are mutually exclusive"); + } + + ## determine hosts to update (those on the cmd-line, config-file, or failed cached) + my @hosts = keys %config; + if (opt('host')) { + @hosts = split_by_comma($opt{'host'}); + } + if (opt('retry')) { + @hosts = map { $_ if $cache{$_}{'status'} ne 'good' } keys %cache; + } + + ## remove any other hosts + my %hosts; + map { $hosts{$_} = undef } @hosts; + map { delete $config{$_} unless exists $hosts{$_} } keys %config; + + ## collect the cacheable variables. + foreach my $proto (keys %services) { + my @cacheable = (); + foreach my $k (keys %{$services{$proto}{'variables'}}) { + push @cacheable, $k if $services{$proto}{'variables'}{$k}{'cache'}; + } + $services{$proto}{'cacheable'} = [ @cacheable ]; + } + + ## sanity check.. + ## make sure config entries have all defaults and they meet minimums + ## first the globals... + foreach my $k (keys %globals) { + my $def = $variables{'merged'}{$k}; + my $ovalue = $globals{$k} // $def->{'default'}; + my $value = check_value($ovalue, $def); + if ($def->{'required'} && !defined $value) { + $value = default($k); + warning("'%s=%s' is an invalid %s. (using default of %s)", $k, $ovalue, $def->{'type'}, $value); + } + $globals{$k} = $value; + } + + ## now the host definitions... + HOST: + foreach my $h (keys %config) { + my $proto; + $proto = $config{$h}{'protocol'}; + $proto = opt('protocol') if !defined($proto); + + load_sha1_support($proto) if (grep (/^$proto$/, ("freedns", "nfsn"))); + load_json_support($proto) if (grep (/^$proto$/, ("1984", "cloudflare", "gandi", "godaddy", "hetzner", "yandex", "nfsn", "njalla"))); + + if (!exists($services{$proto})) { + warning("skipping host: %s: unrecognized protocol '%s'", $h, $proto); + delete $config{$h}; + + } else { + my $svars = $services{$proto}{'variables'}; + my $conf = { 'protocol' => $proto }; + + foreach my $k (keys %$svars) { + my $def = $svars->{$k}; + my $ovalue = $config{$h}{$k} // $def->{'default'}; + my $value = check_value($ovalue, $def); + if ($def->{'required'} && !defined $value) { + warning("skipping host: %s: '%s=%s' is an invalid %s.", $h, $k, $ovalue, $def->{'type'}); + delete $config{$h}; + next HOST; + } + $conf->{$k} = $value; + + } + $config{$h} = $conf; + $config{$h}{'cacheable'} = [ @{$services{$proto}{'cacheable'}} ]; + } + } +} + +###################################################################### +## process_args - +###################################################################### +sub process_args { + my @spec = (); + my $usage = ""; + + foreach (@_) { + if (ref $_) { + my ($key, $specifier, $arg_usage) = @$_; + my $value = default($key); + + ## add a option specifier + push @spec, $key . $specifier; + + ## define the default value which can be overwritten later + $opt{$key} = undef unless exists($opt{$key}); + + next unless $arg_usage; + + ## add a line to the usage; + $usage .= " $arg_usage"; + if (defined($value) && $value ne '') { + $usage .= " (default: "; + if ($specifier eq '!') { + $usage .= "no" if ($specifier eq '!') && !$value; + $usage .= $key; + } else { + $usage .= $value; + } + $usage .= ")"; + } + $usage .= "."; + } else { + $usage .= $_; + } + $usage .= "\n"; + } + ## process the arguments + if (!GetOptions(\%opt, @spec)) { + $opt{"help"} = 1; + } + return $usage; +} + +###################################################################### +## test_possible_ip - print possible IPs +###################################################################### +sub test_possible_ip { + local $opt{'debug'} = 0; + + printf "----- Test_possible_ip with 'get_ip' -----\n"; + printf "use=ip, ip=%s address is %s\n", opt('ip'), get_ip('ip') // 'NOT FOUND' + if defined opt('ip'); + + { + local $opt{'use'} = 'if'; + # Note: The `ip` command adds a `@eth0` suffix to the names of VLAN + # interfaces. That `@eth0` suffix is NOT part of the interface name. + my @ifs = map({ /^[^\s:]*:\s*([^\s:@]+)/ ? $1 : () } + `command -v ip >/dev/null && ip -o link show`); + @ifs = map({ /^([a-zA-Z].*?)(?::?\s.*)?$/ ? $1 : () } + `command -v ifconfig >/dev/null && ifconfig -a`) if $? || !@ifs; + @ifs = () if $?; + warning("failed to get list of interfaces") if !@ifs; + foreach my $if (@ifs) { + local $opt{'if'} = $if; + printf "use=if, if=%s address is %s\n", opt('if'), get_ip('if') // 'NOT FOUND'; + } + } + if (opt('fw')) { + if (opt('fw') !~ m%/%) { + foreach my $fw (sort keys %builtinfw) { + local $opt{'use'} = $fw; + printf "use=%s address is %s\n", $fw, get_ip($fw) // 'NOT FOUND'; + } + } + local $opt{'use'} = 'fw'; + printf "use=fw, fw=%s address is %s\n", opt('fw'), get_ip(opt('fw')) // 'NOT FOUND' + if !exists $builtinfw{opt('fw')}; + + } + { + local $opt{'use'} = 'web'; + foreach my $web (sort keys %builtinweb) { + local $opt{'web'} = $web; + printf "use=web, web=%s address is %s\n", $web, get_ip('web') // 'NOT FOUND'; + } + printf "use=web, web=%s address is %s\n", opt('web'), get_ip('web') // 'NOT FOUND' + if !exists $builtinweb{opt('web')}; + } + if (opt('cmd')) { + local $opt{'use'} = 'cmd'; + printf "use=cmd, cmd=%s address is %s\n", opt('cmd'), get_ip('cmd') // 'NOT FOUND'; + } + + # Now force IPv4 + printf "----- Test_possible_ip with 'get_ipv4' ------\n"; + printf "use=ipv4, ipv4=%s address is %s\n", opt('ipv4'), get_ipv4('ipv4') // 'NOT FOUND' + if defined opt('ipv4'); + + { + # Note: The `ip` command adds a `@eth0` suffix to the names of VLAN + # interfaces. That `@eth0` suffix is NOT part of the interface name. + my @ifs = map({ /^[^\s:]*:\s*([^\s:@]+)/ ? $1 : () } + `command -v ip >/dev/null && ip -o link show`); + @ifs = map({ /^([a-zA-Z].*?)(?::?\s.*)?$/ ? $1 : () } + `command -v ifconfig >/dev/null && ifconfig -a`) if $? || !@ifs; + @ifs = () if $?; + warning("failed to get list of interfaces") if !@ifs; + foreach my $if (@ifs) { + local $opt{'ifv4'} = $if; + printf "use=ifv4, ifv4=%s address is %s\n", opt('ifv4'), get_ipv4('ifv4') // 'NOT FOUND'; + } + } + { + local $opt{'usev4'} = 'webv4'; + foreach my $web (sort keys %builtinweb) { + local $opt{'webv4'} = $web; + printf "use=webv4, webv4=$web address is %s\n", get_ipv4('webv4') // 'NOT FOUND' + if ($web !~ "6") ## Don't bother if web site only supports IPv6; + } + printf "use=webv4, webv4=%s address is %s\n", opt('webv4'), get_ipv4('webv4') // 'NOT FOUND' + if ! exists $builtinweb{opt('webv4')}; + } + if (opt('cmdv4')) { + local $opt{'usev4'} = 'cmdv4'; + printf "use=cmdv4, cmdv4=%s address is %s\n", opt('cmdv4'), get_ipv4('cmdv4') // 'NOT FOUND'; + } + + # Now force IPv6 + printf "----- Test_possible_ip with 'get_ipv6' -----\n"; + printf "use=ipv6, ipv6=%s address is %s\n", opt('ipv6'), get_ipv6('ipv6') // 'NOT FOUND' + if defined opt('ipv6'); + + { + # Note: The `ip` command adds a `@eth0` suffix to the names of VLAN + # interfaces. That `@eth0` suffix is NOT part of the interface name. + my @ifs = map({ /^[^\s:]*:\s*([^\s:@]+)/ ? $1 : () } + `command -v ip >/dev/null && ip -o link show`); + @ifs = map({ /^([a-zA-Z].*?)(?::?\s.*)?$/ ? $1 : () } + `command -v ifconfig >/dev/null && ifconfig -a`) if $? || !@ifs; + @ifs = () if $?; + warning("failed to get list of interfaces") if !@ifs; + foreach my $if (@ifs) { + local $opt{'ifv6'} = $if; + printf "use=ifv6, ifv6=%s address is %s\n", opt('ifv6'), get_ipv6('ifv6') // 'NOT FOUND'; + } + } + { + local $opt{'usev6'} = 'webv6'; + foreach my $web (sort keys %builtinweb) { + local $opt{'webv6'} = $web; + printf "use=webv6, webv6=$web address is %s\n", get_ipv6('webv6') // 'NOT FOUND' + if ($web !~ "4"); ## Don't bother if web site only supports IPv4 + } + printf "use=webv6, webv6=%s address is %s\n", opt('webv6'), get_ipv6('webv6') // 'NOT FOUND' + if ! exists $builtinweb{opt('webv6')}; + } + if (opt('cmdv6')) { + local $opt{'usev6'} = 'cmdv6'; + printf "use=cmdv6, cmdv6=%s address is %s\n", opt('cmdv6'), get_ipv6('cmdv6') // 'NOT FOUND'; + } + + exit 0 unless opt('debug'); +} +###################################################################### +## test_geturl - print (and save if -test) result of fetching a URL +###################################################################### +sub test_geturl { + my $url = shift; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => opt('login'), + password => opt('password'), + ); + print "URL $url\n"; + print $reply // "\n"; + exit; +} +###################################################################### +## load_file +###################################################################### +sub load_file { + my $file = shift; + my $buffer = ''; + + if (exists($ENV{'TEST_CASE'})) { + my $try = "$file-$ENV{'TEST_CASE'}"; + $file = $try if -f $try; + } + + local *FD; + if (open(FD, "< $file")) { + read(FD, $buffer, -s FD); + close(FD); + debug("Loaded %d bytes from %s", length($buffer), $file); + } else { + debug("Load failed from %s (%s)", $file, $!); + } + return $buffer; +} +###################################################################### +## save_file +###################################################################### +sub save_file { + my ($file, $buffer, $opt) = @_; + + $file .= "-$ENV{'TEST_CASE'}" if exists $ENV{'TEST_CASE'}; + if (defined $opt) { + my $i = 0; + while (-f "$file-$i") { + if ('unique' =~ /^$opt/i) { + my $a = join('\n', grep {!/^Date:/} split /\n/, $buffer); + my $b = join('\n', grep {!/^Date:/} split /\n/, load_file("$file-$i")); + last if $a eq $b; + } + $i++; + } + $file = "$file-$i"; + } + debug("Saving to %s", $file); + local *FD; + open(FD, "> $file") or return; + print FD $buffer; + close(FD); + return $buffer; +} +###################################################################### +## print_opt +## print_globals +## print_config +## print_cache +## print_info +###################################################################### +sub _print_hash { + my ($string, $ptr) = @_; + my $value = $ptr; + + if (!defined($ptr)) { + $value = ""; + } elsif (ref $ptr eq 'HASH') { + foreach my $key (sort keys %$ptr) { + if (($key eq "login") || ($key eq "password")) { + $value = ""; + } else { + $value = $ptr->{$key}; + } + _print_hash("${string}\{$key\}", $value); + } + return; + } + printf "%-36s : %s\n", $string, $value; +} +sub print_hash { + my ($string, $hash) = @_; + printf "=== %s ====\n", $string; + _print_hash($string, $hash); +} +sub print_opt { print_hash("opt", \%opt); } +sub print_globals { print_hash("globals", \%globals); } +sub print_config { print_hash("config", \%config); } +sub print_cache { print_hash("cache", \%cache); } +sub print_info { + print_opt(); + print_globals(); + print_config(); + print_cache(); +} +###################################################################### +## pipecmd - run an external command +## logger +## sendmail +###################################################################### +sub pipecmd { + my $cmd = shift; + my $stdin = join("\n", @_); + my $ok = 0; + + ## remove trailing newlines + 1 while chomp($stdin); + + ## override when debugging. + $cmd = opt('exec') ? "| $cmd" : "> /dev/null"; + + ## execute the command. + local *FD; + if (!open(FD, $cmd)) { + printf STDERR "%s: cannot execute command %s.\n", $program, $cmd; + + } elsif ($stdin && (!print FD "$stdin\n")) { + printf STDERR "%s: failed writting to %s.\n", $program, $cmd; + close(FD); + + } elsif (!close(FD)) { + printf STDERR "%s: failed closing %s.(%s)\n", $program, $cmd, $@; + + } elsif (opt('exec') && $?) { + printf STDERR "%s: failed %s. (%s)\n", $program, $cmd, $@; + + } else { + $ok = 1; + } + return $ok; +} +sub logger { + if (opt('syslog') && opt('facility') && opt('priority')) { + my $facility = opt('facility'); + my $priority = opt('priority'); + return pipecmd("logger -p$facility.$priority -t${program}\[$$\]", @_); + } + return 1; +} +sub sendmail { + my $recipients = opt('mail'); + + if (opt('mail-failure') && ($result ne 'OK' && $result ne '0')) { + $recipients = opt('mail-failure'); + } + if ($msgs && $recipients && $msgs ne $last_msgs) { + pipecmd("sendmail -oi $recipients", + "To: $recipients", + "Subject: status report from $program\@$hostname", + "\r\n", + $msgs, + "", + "regards,", + " $program\@$hostname (version $version)" + ); + } + $last_msgs = $msgs; + $msgs = ''; +} +###################################################################### +## split_by_comma +## merge +## default +## minimum +## opt +###################################################################### +sub split_by_comma { + my $string = shift; + + return split /\s*[, ]\s*/, $string if defined $string; + return (); +} +sub merge { + my %merged = (); + foreach my $h (@_) { + foreach my $k (keys %$h) { + $merged{$k} = $h->{$k} unless exists $merged{$k}; + } + } + return \%merged; +} +sub default { + my $v = shift; + return $variables{'merged'}{$v}{'default'}; +} +sub minimum { + my $v = shift; + return $variables{'merged'}{$v}{'minimum'}; +} +sub opt { + my $v = shift; + my $h = shift; + return $config{$h}{$v} if defined($h) && defined($config{$h}{$v}); + return $opt{$v} // $globals{$v} // default($v); +} +sub min { + my $min = shift; + foreach my $arg (@_) { + $min = $arg if $arg < $min; + } + return $min; +} +sub max { + my $max = shift; + foreach my $arg (@_) { + $max = $arg if $arg > $max; + } + return $max; +} +###################################################################### +## ynu +###################################################################### +sub ynu { + my ($value, $yes, $no, $undef) = @_; + + return $no if !($value // ''); + return $yes if $value eq '1'; + foreach (qw(yes true)) { + return $yes if $_ =~ /^$value/i; + } + foreach (qw(no false)) { + return $no if $_ =~ /^$value/i; + } + return $undef; +} +###################################################################### +## msg +## debug +## warning +## fatal +###################################################################### +sub _msg { + my $fh = shift; + my $log = shift; + my $prefix = shift; + my $format = shift; + my $buffer = sprintf $format, @_; + chomp($buffer); + + $prefix = sprintf "%-9s ", $prefix if $prefix; + if ($file) { + $prefix .= "file $file"; + $prefix .= ", line $lineno" if $lineno; + $prefix .= ": "; + } + if ($prefix) { + $buffer = "$prefix$buffer"; + $buffer =~ s/\n/\n$prefix/g; + } + $buffer .= "\n"; + print $fh $buffer; + + $msgs .= $buffer if $log; + logger($buffer) if $log; + +} +sub msg { _msg(*STDOUT, 0, '', @_); } +sub verbose { _msg(*STDOUT, 1, @_) if opt('verbose'); } +sub info { _msg(*STDOUT, 1, 'INFO:', @_) if opt('verbose'); } +sub debug { _msg(*STDOUT, 0, 'DEBUG:', @_) if opt('debug'); } +sub debug2 { _msg(*STDOUT, 0, 'DEBUG:', @_) if opt('debug') && opt('verbose'); } +sub warning { _msg(*STDERR, 1, 'WARNING:', @_); } +sub fatal { _msg(*STDERR, 1, 'FATAL:', @_); sendmail(); exit(1); } +sub success { _msg(*STDOUT, 1, 'SUCCESS:', @_); } +sub failed { _msg(*STDERR, 1, 'FAILED:', @_); $result = 'FAILED'; } +sub prettytime { return scalar(localtime(shift)); } + +sub prettyinterval { + my $interval = shift; + use integer; + my $s = $interval % 60; $interval /= 60; + my $m = $interval % 60; $interval /= 60; + my $h = $interval % 24; $interval /= 24; + my $d = $interval; + + my $string = ""; + $string .= "$d day" if $d; + $string .= "s" if $d > 1; + $string .= ", " if $string && $h; + $string .= "$h hour" if $h; + $string .= "s" if $h > 1; + $string .= ", " if $string && $m; + $string .= "$m minute" if $m; + $string .= "s" if $m > 1; + $string .= ", " if $string && $s; + $string .= "$s second" if $s; + $string .= "s" if $s > 1; + return $string; +} +sub interval { + my $value = shift; + if ($value =~ /^(\d+)(seconds|s)/i) { + $value = $1; + } elsif ($value =~ /^(\d+)(minutes|m)/i) { + $value = $1 * 60; + } elsif ($value =~ /^(\d+)(hours|h)/i) { + $value = $1 * 60*60; + } elsif ($value =~ /^(\d+)(days|d)/i) { + $value = $1 * 60*60*24; + } elsif ($value !~ /^\d+$/) { + $value = undef; + } + return $value; +} +sub interval_expired { + my ($host, $time, $interval) = @_; + + return 1 if !exists $cache{$host}; + return 1 if !exists $cache{$host}{$time} || !$cache{$host}{$time}; + return 1 if !exists $config{$host}{$interval} || !$config{$host}{$interval}; + + return $now > ($cache{$host}{$time} + $config{$host}{$interval}); +} + + + +###################################################################### +## check_value +###################################################################### +sub check_value { + my ($value, $def) = @_; + my $type = $def->{'type'}; + my $min = $def->{'minimum'}; + my $required = $def->{'required'}; + + if (!defined $value && !$required) { + ; + + } elsif ($type eq T_DELAY) { + $value = interval($value); + $value = $min if defined($value) && defined($min) && $value < $min; + + } elsif ($type eq T_NUMBER) { + return undef if $value !~ /^\d+$/; + $value = $min if defined($min) && $value < $min; + + } elsif ($type eq T_BOOL) { + if ($value =~ /^(y(es)?|t(rue)?|1)$/i) { + $value = 1; + } elsif ($value =~ /^(n(o)?|f(alse)?|0)$/i) { + $value = 0; + } else { + return undef; + } + } elsif ($type eq T_FQDN || $type eq T_OFQDN && $value ne '') { + $value = lc $value; + return undef if $value !~ /[^.]\.[^.]/; + + } elsif ($type eq T_FQDNP) { + $value = lc $value; + return undef if $value !~ /[^.]\.[^.].*(:\d+)?$/; + + } elsif ($type eq T_PROTO) { + $value = lc $value; + return undef if !exists $services{$value}; + + } elsif ($type eq T_USE) { + $value = lc $value; + return undef if !exists $ip_strategies{$value}; + + } elsif ($type eq T_USEV4) { + $value = lc $value; + return undef if ! exists $ipv4_strategies{$value}; + + } elsif ($type eq T_USEV6) { + $value = lc $value; + return undef if ! exists $ipv6_strategies{$value}; + + } elsif ($type eq T_FILE) { + return undef if $value eq ""; + + } elsif ($type eq T_IF) { + return undef if $value !~ /^[a-zA-Z0-9:._-]+$/; + + } elsif ($type eq T_PROG) { + return undef if $value eq ""; + + } elsif ($type eq T_LOGIN) { + return undef if $value eq ""; + + } elsif ($type eq T_IP) { + return undef if !is_ipv4($value) && !is_ipv6($value); + + } elsif ($type eq T_IPV4) { + return undef if !is_ipv4($value); + + } elsif ($type eq T_IPV6) { + return undef if !is_ipv6($value); + + } + return $value; +} +###################################################################### +## encode_base64 - from MIME::Base64 +###################################################################### +sub encode_base64 ($;$) { + my $res = ''; + my $eol = $_[1]; + $eol = "\n" unless defined $eol; + pos($_[0]) = 0; # ensure start at the beginning + while ($_[0] =~ /(.{1,45})/gs) { + $res .= substr(pack('u', $1), 1); + chop($res); + } + $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs + + # fix padding at the end + my $padding = (3 - length($_[0]) % 3) % 3; + $res =~ s/.{$padding}$/'=' x $padding/e if $padding; + $res; +} +###################################################################### +## load_ssl_support +###################################################################### +sub load_ssl_support { + my $ssl_loaded = eval { require IO::Socket::SSL }; + unless ($ssl_loaded) { + fatal("%s", <<"EOM"); +Error loading the Perl module IO::Socket::SSL needed for SSL connect. +On Debian, the package libio-socket-ssl-perl must be installed. +On Red Hat, the package perl-IO-Socket-SSL must be installed. +On Alpine, the package perl-io-socket-ssl must be installed. +EOM + } + import IO::Socket::SSL; + { no warnings; $IO::Socket::SSL::DEBUG = 0; } +} + +###################################################################### +## load_ipv6_support +###################################################################### +sub load_ipv6_support { + my $ipv6_loaded = eval { require IO::Socket::INET6 }; + unless ($ipv6_loaded) { + fatal("%s", <<"EOM"); +Error loading the Perl module IO::Socket::INET6 needed for ipv6 connect. +On Debian, the package libio-socket-inet6-perl must be installed. +On Red Hat, the package perl-IO-Socket-INET6 must be installed. +On Alpine, the package perl-io-socket-inet6 must be installed. +EOM + } + import IO::Socket::INET6; + { no warnings; $IO::Socket::INET6::DEBUG = 0; } +} + +###################################################################### +## load_sha1_support +###################################################################### +sub load_sha1_support { + my $why = shift; + my $sha1_loaded = eval { require Digest::SHA1 }; + my $sha_loaded = eval { require Digest::SHA }; + unless ($sha1_loaded || $sha_loaded) { + fatal("%s", <<"EOM"); +Error loading the Perl module Digest::SHA1 or Digest::SHA needed for $why update. +On Debian, the package libdigest-sha1-perl or libdigest-sha-perl must be installed. +EOM + } + if ($sha1_loaded) { + import Digest::SHA1 (qw/sha1_hex/); + } elsif ($sha_loaded) { + import Digest::SHA (qw/sha1_hex/); + } +} +###################################################################### +## load_json_support +###################################################################### +sub load_json_support { + my $why = shift; + my $json_loaded = eval { require JSON::PP }; + unless ($json_loaded) { + fatal("%s", <<"EOM"); +Error loading the Perl module JSON::PP needed for $why update. +EOM + } + import JSON::PP (qw/decode_json encode_json/); +} + +###################################################################### +## geturl +###################################################################### +sub geturl { + return opt('curl') ? fetch_via_curl(@_) : fetch_via_socket_io(@_); +} + +sub fetch_via_socket_io { + my %params = @_; + my $proxy = $params{proxy}; + my $url = $params{url}; + my $login = $params{login}; + my $password = $params{password}; + my $ipversion = $params{ipversion} // ''; + my $headers = $params{headers} // ''; + my $method = $params{method} // 'GET'; + my $data = $params{data} // ''; + my ($peer, $server, $port, $default_port, $use_ssl); + my ($sd, $request, $reply); + + ## canonify proxy and url + my $force_ssl; + $force_ssl = 1 if ($url =~ /^https:/); + $proxy =~ s%^https?://%%i if defined($proxy); + $url =~ s%^https?://%%i; + $server = $url; + $server =~ s%[?/].*%%; + $url =~ s%^[^?/]*/?%%; + + if ($force_ssl || ($globals{'ssl'} && !($params{ignore_ssl_option} // 0))) { + $use_ssl = 1; + $default_port = '443'; + } else { + $use_ssl = 0; + $default_port = '80'; + } + debug("proxy = %s", $proxy // ''); + debug("protocol = %s", $use_ssl ? "https" : "http"); + debug("server = %s", $server); + (my $_url = $url) =~ s%\?.*%?%; #redact ALL parameters passed on URL, including possible passwords + debug("url = %s", $_url); + debug("ip ver = %s", $ipversion); + + ## determine peer and port to use. + $peer = $proxy // $server; + $peer =~ s%[?/].*%%; + if ($peer =~ /^\[([^]]+)\](?::(\d+))?$/ || $peer =~ /^([^:]+)(?::(\d+))?/) { + $peer = $1; + $port = $2 // $default_port; + } else { + failed("unable to extract host and port from %s", $peer); + return undef; + } + + $request = "$method "; + if (!$use_ssl) { + $request .= "http://$server" if defined($proxy); + } else { + $request .= "https://$server" if defined($proxy); + } + $request .= "/$url HTTP/1.1\n"; + $request .= "Host: $server\n"; + + if (defined($login) || defined($password)) { + my $auth = encode_base64(($login // '') . ':' . ($password // ''), ''); + $request .= "Authorization: Basic $auth\n"; + } + $request .= "User-Agent: ${program}/${version}\n"; + if ($data) { + $request .= "Content-Type: application/x-www-form-urlencoded\n" if $headers !~ /^Content-Type:/mi; + $request .= "Content-Length: " . length($data) . "\n"; + } + $request .= "Connection: close\n"; + $headers .= "\n" if $headers ne '' && substr($headers, -1) ne "\n"; + $request .= $headers; + $request .= "\n"; + # RFC 7230 says that all lines before the body must end with . + (my $rq = $request) =~ s/(? $peer, + PeerPort => $port, + Proto => 'tcp', + MultiHomed => 1, + Timeout => opt('timeout'), + ); + my $socket_class = 'IO::Socket::INET'; + if ($use_ssl) { + # IO::Socket::SSL will load IPv6 support if available on the system. + load_ssl_support; + $socket_class = 'IO::Socket::SSL'; + $socket_args{SSL_ca_file} = opt('ssl_ca_file') if defined(opt('ssl_ca_file')); + $socket_args{SSL_ca_path} = opt('ssl_ca_dir') if defined(opt('ssl_ca_dir')); + $socket_args{SSL_verify_mode} = ($params{ssl_validate} // 1) + ? IO::Socket::SSL->SSL_VERIFY_PEER + : IO::Socket::SSL->SSL_VERIFY_NONE; + } elsif ($globals{'ipv6'} || $ipversion eq '6') { + load_ipv6_support; + $socket_class = 'IO::Socket::INET6'; + } + if (defined($params{_testonly_socket_class})) { + $socket_args{original_socket_class} = $socket_class; + $socket_class = $params{_testonly_socket_class}; + } + if ($ipversion eq '4') { + $socket_args{Domain} = PF_INET; + $socket_args{Family} = AF_INET; + } elsif ($ipversion eq '6') { + $socket_args{Domain} = PF_INET6; + $socket_args{Family} = AF_INET6; + } elsif ($ipversion ne '') { + fatal("geturl passed unsupported 'ipversion' value %s", $ipversion); + } + + my $ipv = $ipversion eq '' ? '' : sprintf(" (IPv%s)", $ipversion); + my $peer_port_ipv = sprintf("%s:%s%s", $peer, $port, $ipv); + my $to = sprintf("%s%s%s", $server, defined($proxy) ? " via proxy $peer:$port" : "", $ipv); + verbose("CONNECT:", "%s", $to); + $0 = sprintf("%s - connecting to %s", $program, $peer_port_ipv); + if (opt('exec')) { + $sd = $socket_class->new(%socket_args); + defined($sd) or warning("cannot connect to %s socket: %s%s", $peer_port_ipv, $@, + $use_ssl ? ' ' . IO::Socket::SSL::errstr() : ''); + } else { + debug("skipped network connection"); + verbose("SENDING:", "%s", $request); + } + if (defined $sd) { + ## send the request to the http server + verbose("CONNECTED: ", $use_ssl ? 'using SSL' : 'using HTTP'); + verbose("SENDING:", "%s", $request); + + $0 = sprintf("%s - sending to %s", $program, $peer_port_ipv); + my $result = syswrite $sd, $rq; + if ($result != length($rq)) { + warning("cannot send to %s (%s).", $peer_port_ipv, $!); + } else { + $0 = sprintf("%s - reading from %s", $program, $peer_port_ipv); + eval { + local $SIG{'ALRM'} = sub { die "timeout"; }; + alarm(opt('timeout')) if opt('timeout') > 0; + while ($_ = <$sd>) { + $0 = sprintf("%s - read from %s", $program, $peer_port_ipv); + verbose("RECEIVE:", "%s", $_ // ""); + $reply .= $_ // ''; + } + if (opt('timeout') > 0) { + alarm(0); + } + }; + close($sd); + + if ($@ and $@ =~ /timeout/) { + warning("TIMEOUT: %s after %s seconds", $to, opt('timeout')); + $reply = ''; + } + $reply //= ''; + } + } + $0 = sprintf("%s - closed %s", $program, $peer_port_ipv); + + ## during testing simulate reading the URL + if (opt('test')) { + my $filename = "$server/$url"; + $filename =~ s|/|%2F|g; + if (opt('exec')) { + $reply = save_file("$savedir/$filename", $reply, 'unique'); + } else { + $reply = load_file("$savedir/$filename"); + } + } + + $reply =~ s/\r//g if defined $reply; + return $reply; +} + +###################################################################### +## curl_cmd() function to execute system curl command +###################################################################### +sub curl_cmd { + my @params = @_; + my $tmpfile; + my $tfh; + my $system_curl = quotemeta(subst_var('@CURL@', 'curl')); + my %curl_codes = ( ## Subset of error codes from https://curl.haxx.se/docs/manpage.html + 2 => "Failed to initialize. (Most likely a bug in ddclient, please open issue at https://github.com/ddclient/ddclient)", + 3 => "URL malformed. The syntax was not correct", + 5 => "Couldn't resolve proxy. The given proxy host could not be resolved.", + 6 => "Couldn't resolve host. The given remote host was not resolved.", + 7 => "Failed to connect to host.", + 22 => "HTTP page not retrieved. The requested url was not found or returned another error.", + 28 => "Operation timeout. The specified time-out period was reached according to the conditions.", + 35 => "SSL connect error. The SSL handshaking failed.", + 47 => "Too many redirects. When following redirects, curl hit the maximum amount.", + 52 => "The server didn't reply anything, which here is considered an error.", + 51 => "The peer's SSL certificate or SSH MD5 fingerprint was not OK.", + 58 => "Problem with the local certificate.", + 60 => "Peer certificate cannot be authenticated with known CA certificates.", + 67 => "The user name, password, or similar was not accepted and curl failed to log in.", + 77 => "Problem with reading the SSL CA cert (path? access rights?).", + 78 => "The resource referenced in the URL does not exist.", + 127 => "You requested network access with curl but $system_curl was not found", + ); + + debug("CURL: %s", $system_curl); + fatal("curl not found") if ($system_curl eq ''); + return '' if (scalar(@params) == 0); ## no parameters provided + + # Hard code to /tmp rather than use system TMPDIR to protect from malicious + # shell instructions in TMPDIR environment variable. All systems should have /tmp. + $tfh = File::Temp->new(DIR => '/tmp', + TEMPLATE => 'ddclient_XXXXXXXXXX'); + $tmpfile = $tfh->filename; + + debug("CURL Tempfile: %s", $tmpfile); + { + local $\ = "\n"; ## Terminate the file, + local $, = "\n"; ## and each parameter, with a newline. + print($tfh @params); + } + close($tfh); + my $reply = qx{ $system_curl --config $tmpfile 2>/dev/null; }; + if ((my $rc = $?>>8) != 0) { + warning("CURL error (%d) %s", $rc, $curl_codes{$rc} // "Unknown return code. Check $system_curl is installed and its manpage."); + } + return $reply; +} + +###################################################################### +## escape_curl_param() makes sure any special characters within a +## curl parameter is properly escaped. +###################################################################### +sub escape_curl_param { + my $str = shift // ''; + + return '' if ($str eq ''); + $str =~ s/\\/\\\\/g;## Escape backslashes + $str =~ s/"/\\"/g; ## Escape double-quotes + $str =~ s/\n/\\n/g; ## Escape newline + $str =~ s/\r/\\r/g; ## Escape carrage return + $str =~ s/\t/\\t/g; ## Escape tabs + $str =~ s/\v/\\v/g; ## Escape vertical whitespace + return $str; +} + +###################################################################### +## fetch_via_curl() is used for geturl() when global curl option set +###################################################################### +sub fetch_via_curl { + my %params = @_; + my $proxy = $params{proxy}; + my $url = $params{url}; + my $login = $params{login}; + my $password = $params{password}; + my $ipversion = ($params{ipversion}) ? int($params{ipversion}) : 0; + my $headers = $params{headers} // ''; + my $method = $params{method} // 'GET'; + my $data = $params{data} // ''; + + my $reply; + my $server; + my $use_ssl = 0; + my $force_ssl = 0; + my $protocol; + my $timeout = opt('timeout'); + my @curlopt = (); + my @header_lines = (); + + ## canonify proxy and url + $force_ssl = 1 if ($url =~ /^https:/); + $proxy =~ s%^https?://%%i if defined($proxy); + $url =~ s%^https?://%%i; + $server = $url; + $server =~ s%[?/].*%%; + $url =~ s%^[^?/]*/?%%; + + $use_ssl = 1 if ($force_ssl || ($globals{'ssl'} && !($params{ignore_ssl_option} // 0))); + + $protocol = ($use_ssl ? "https" : "http"); + + debug("proxy = %s", $proxy // ''); + debug("protocol = %s", $protocol); + debug("server = %s", $server); + (my $_url = $url) =~ s%\?.*%?%; #redact possible credentials + debug("url = %s", $_url); + debug("ip ver = %s", $ipversion); + + if (!opt('exec')) { + debug("skipped network connection"); + verbose("SENDING:", "%s", "${server}/${url}"); + } else { + my $curl_loaded = eval { require WWW::Curl::Easy }; + if ($curl_loaded) { + # System has the WWW::Curl::Easy module so use that + import WWW::Curl::Easy; + my $curl = WWW::Curl::Easy->new; + + $curl->setopt(WWW::Curl::Easy->CURLOPT_HEADER, 1); ## Include HTTP response for compatibility + $curl->setopt(WWW::Curl::Easy->CURLOPT_SSL_VERIFYPEER, ($params{ssl_validate} // 1) ? 1 : 0 ); + $curl->setopt(WWW::Curl::Easy->CURLOPT_SSL_VERIFYHOST, ($params{ssl_validate} // 1) ? 1 : 0 ); + $curl->setopt(WWW::Curl::Easy->CURLOPT_CAINFO, opt('ssl_ca_file')) if defined(opt('ssl_ca_file')); + $curl->setopt(WWW::Curl::Easy->CURLOPT_CAPATH, opt('ssl_ca_dir')) if defined(opt('ssl_ca_dir')); + $curl->setopt(WWW::Curl::Easy->CURLOPT_IPRESOLVE, + ($ipversion == 4) ? WWW::Curl::Easy->CURL_IPRESOLVE_V4 : + ($ipversion == 6) ? WWW::Curl::Easy->CURL_IPRESOLVE_V6 : + WWW::Curl::Easy->CURL_IPRESOLVE_WHATEVER); + $curl->setopt(WWW::Curl::Easy->CURLOPT_USERAGENT, "${program}/${version}"); + $curl->setopt(WWW::Curl::Easy->CURLOPT_CONNECTTIMEOUT, $timeout); + $curl->setopt(WWW::Curl::Easy->CURLOPT_TIMEOUT, $timeout); + + $curl->setopt(WWW::Curl::Easy->CURLOPT_POST, 1) if ($method eq 'POST'); + $curl->setopt(WWW::Curl::Easy->CURLOPT_PUT, 1) if ($method eq 'PUT'); + $curl->setopt(WWW::Curl::Easy->CURLOPT_CUSTOMREQUEST, $method) if ($method ne 'GET'); ## for PATCH + + $curl->setopt(WWW::Curl::Easy->CURLOPT_USERPWD, "${login}:${password}") if (defined($login) && defined($password)); + $curl->setopt(WWW::Curl::Easy->CURLOPT_PROXY, "${protocol}://${proxy}") if defined($proxy); + $curl->setopt(WWW::Curl::Easy->CURLOPT_URL, "${protocol}://${server}/${url}"); + + # Add header lines if any was provided + if ($headers) { + @header_lines = split('\n', $headers); + $curl->setopt(WWW::Curl::Easy->CURLOPT_HTTPHEADER, \@header_lines); + } + # Add in the data if any was provided (for POST/PATCH) + if (my $datalen = length($data)) { + $curl->setopt(WWW::Curl::Easy->CURLOPT_POSTFIELDS, ${data}); + $curl->setopt(WWW::Curl::Easy->CURLOPT_POSTFIELDSIZE, $datalen); + } + $curl->setopt(WWW::Curl::Easy->CURLOPT_WRITEDATA,\$reply); + + # don't include ${url} as that might expose login credentials + $0 = sprintf("%s - WWW::Curl::Easy sending to %s", $program, "${protocol}://${server}"); + verbose("SENDING:", "WWW::Curl::Easy to %s", "${protocol}://${server}"); + verbose("SENDING:", "%s", $headers) if ($headers); + verbose("SENDING:", "%s", $data) if ($data); + + my $rc = $curl->perform; + + if ($rc != 0) { + warning("CURL error (%d) %s", $rc, $curl->strerror($rc)); + debug($curl->errbuf); + } + } else { + # System does not have the WWW::Curl::Easy module so attempt with system Curl command + push(@curlopt, "silent"); + push(@curlopt, "include"); ## Include HTTP response for compatibility + push(@curlopt, "insecure") if ($use_ssl && !($params{ssl_validate} // 1)); + push(@curlopt, "cacert=\"".escape_curl_param(opt('ssl_ca_file')).'"') if defined(opt('ssl_ca_file')); + push(@curlopt, "capath=\"".escape_curl_param(opt('ssl_ca_dir')).'"') if defined(opt('ssl_ca_dir')); + push(@curlopt, "ipv4") if ($ipversion == 4); + push(@curlopt, "ipv6") if ($ipversion == 6); + push(@curlopt, "user-agent=\"".escape_curl_param("${program}/${version}").'"'); + push(@curlopt, "connect-timeout=$timeout"); + push(@curlopt, "max-time=$timeout"); + push(@curlopt, "request=$method"); + push(@curlopt, "user=\"".escape_curl_param("${login}:${password}").'"') if (defined($login) && defined($password)); + push(@curlopt, "proxy=\"".escape_curl_param("${protocol}://${proxy}").'"') if defined($proxy); + push(@curlopt, "url=\"".escape_curl_param("${protocol}://${server}/${url}").'"'); + + # Each header line is added individually + @header_lines = split('\n', $headers); + $_ = "header=\"".escape_curl_param($_).'"' foreach (@header_lines); + push(@curlopt, @header_lines); + + # Add in the data if any was provided (for POST/PATCH) + push(@curlopt, "data=\"".escape_curl_param(${data}).'"') if ($data); + + # don't include ${url} as that might expose login credentials + $0 = sprintf("%s - Curl system cmd sending to %s", $program, "${protocol}://${server}"); + verbose("SENDING:", "Curl system cmd to %s", "${protocol}://${server}"); + verbose("SENDING:", "%s", $_) foreach (@curlopt); + + $reply = curl_cmd(@curlopt); + } + verbose("RECEIVE:", "%s", $reply // ""); + if (!$reply) { + # don't include ${url} as that might expose login credentials + warning("curl cannot connect to %s://%s using IPv%s",${protocol},${server},$ipversion); + } + } + + ## during testing simulate reading the URL + if (opt('test')) { + my $filename = "$server/$url"; + $filename =~ s|/|%2F|g; + if (opt('exec')) { + $reply = save_file("$savedir/$filename", $reply, 'unique'); + } else { + $reply = load_file("$savedir/$filename"); + } + } + + $reply =~ s/\r//g if defined $reply; + return $reply; +} + +###################################################################### +## get_ip +###################################################################### +sub get_ip { + my $use = lc shift; + $use = 'disabled' if ($use eq 'no'); # backward compatibility + my $h = shift; + my ($ip, $arg, $reply, $url, $skip) = (undef, opt($use, $h), ''); + $arg = '' unless $arg; + + if ($use eq 'ip') { + $ip = opt('ip', $h); + if (!is_ipv4($ip) && !is_ipv6($ip)) { + warning("'%s' is not a valid IPv4 or IPv6 address", $ip // ''); + $ip = undef; + } + $arg = 'ip'; + + } elsif ($use eq 'if') { + $ip = get_ip_from_interface($arg); + + } elsif ($use eq 'cmd') { + if ($arg) { + $skip = opt('cmd-skip', $h) // ''; + $reply = `$arg`; + $reply = '' if $?; + } + + } elsif ($use eq 'web') { + $url = opt('web', $h) // ''; + $skip = opt('web-skip', $h) // ''; + + if (exists $builtinweb{$url}) { + $skip = $builtinweb{$url}->{'skip'} unless $skip; + $url = $builtinweb{$url}->{'url'}; + } + $arg = $url; + + if ($url) { + $reply = geturl( + proxy => opt('proxy', $h), + url => $url, + ssl_validate => opt('web-ssl-validate', $h), + ) // ''; + } + + } elsif (($use eq 'cisco')) { + # Stuff added to support Cisco router ip http daemon + # User fw-login should only have level 1 access to prevent + # password theft. This is pretty harmless. + my $queryif = opt('if', $h); + $skip = opt('fw-skip', $h) // ''; + + # Convert slashes to protected value "\/" + $queryif =~ s%\/%\\\/%g; + + # Protect special HTML characters (like '?') + $queryif =~ s/([\?&= ])/sprintf("%%%02x", ord($1))/ge; + + $url = "http://" . opt('fw', $h) . "/level/1/exec/show/ip/interface/brief/${queryif}/CR"; + $reply = geturl( + url => $url, + login => opt('fw-login', $h), + password => opt('fw-password', $h), + ignore_ssl_option => 1, + ssl_validate => opt('fw-ssl-validate', $h), + ) // ''; + $arg = $url; + + } elsif (($use eq 'cisco-asa')) { + # Stuff added to support Cisco ASA ip https daemon + # User fw-login should only have level 1 access to prevent + # password theft. This is pretty harmless. + my $queryif = opt('if', $h); + $skip = opt('fw-skip', $h) // ''; + + # Convert slashes to protected value "\/" + $queryif =~ s%\/%\\\/%g; + + # Protect special HTML characters (like '?') + $queryif =~ s/([\?&= ])/sprintf("%%%02x", ord($1))/ge; + + $url = "https://" . opt('fw', $h) . "/exec/show%20interface%20${queryif}"; + $reply = geturl( + url => $url, + login => opt('fw-login', $h), + password => opt('fw-password', $h), + ignore_ssl_option => 1, + ssl_validate => opt('fw-ssl-validate', $h), + ) // ''; + $arg = $url; + + } elsif ($use eq 'disabled') { + ## This is a no-op... Do not get an IP address for this host/service + $reply = ''; + + } else { + $url = opt('fw', $h) // ''; + $skip = opt('fw-skip', $h) // ''; + + if (exists $builtinfw{$use}) { + $skip = $builtinfw{$use}->{'skip'} unless $skip; + $url = "http://${url}" . $builtinfw{$use}->{'url'} unless $url =~ /\//; + } + $arg = $url; + + if ($url) { + $reply = geturl( + url => $url, + login => opt('fw-login', $h), + password => opt('fw-password', $h), + ignore_ssl_option => 1, + ssl_validate => opt('fw-ssl-validate', $h), + ) // ''; + } + } + if (!defined $reply) { + $reply = ''; + } + if (($skip // '') ne '') { + $skip =~ s/ /\\s/is; + $reply =~ s/^.*?${skip}//is; + } + $ip //= extract_ipv4($reply) // extract_ipv6($reply); + warning("found neither IPv4 nor IPv6 address") if !defined($ip); + if ($use ne 'ip' && ($ip // '') eq '0.0.0.0') { + $ip = undef; + } + + debug("get_ip: using %s, %s reports %s", $use, $arg, $ip // ""); + return $ip; +} + +###################################################################### +## Regex to find IPv4 address. Accepts embedded leading zeros. +###################################################################### +my $regex_ipv4 = qr/(?:(?25[0-5]|2[0-4]\d|[01]?\d\d?)\.){3}(?&octet)/; + +###################################################################### +## is_ipv4() validates if string is valid IPv4 address with no preceding +## or trailing spaces/characters, not even line breaks. +###################################################################### +sub is_ipv4 { + return (shift // '') =~ /\A$regex_ipv4\z/; +} + +###################################################################### +## extract_ipv4() finds the first valid IPv4 address in the given string, +## removes embedded leading zeros, and returns the result. +###################################################################### +sub extract_ipv4 { + (shift // '') =~ /(?:\b|_)($regex_ipv4)(?:\b|_)/ or return undef; + (my $ip = $1) =~ s/\b0+\B//g; ## remove embedded leading zeros + return $ip; +} + +###################################################################### +## Regex that matches an IPv6 address. Accepts embedded leading zeros. +## Accepts IPv4-mapped IPv6 addresses such as 64:ff9b::192.0.2.13. +###################################################################### +my $regex_ipv6 = qr/ + # Define some named groups so we can use Perl's recursive subpattern feature for shorthand: + (?[0-9A-F]{1,4}){0} # "g" matches a group of 1 to 4 hex chars + (?(?&g):){0} # "g_" matches a group of 1 to 4 hex chars followed by a colon + (?<_g>:(?&g)){0} # "_g" matches a colon followed by a group of 1 to 4 hex chars + (?(?&g)?){0} # "g0" is an optional "g" (matches a group of 0 to 4 hex chars) + (?(?&g0):){0} # "g0_" is an optional "g" followed by a colon + (?[:.0-9A-Z]){0} # "x" matches chars that should never come before or after the address + (?$regex_ipv4){0} # "ip4" matches an IPv4 address x.x.x.x + + # Now for the regex itself: + (?/dev/null }; + ## Fallback is the netstat command. This is only option on MacOS. + if ($?) { $cmd = "netstat -rn -$ipver"; $reply = qx{ $cmd 2>/dev/null }; } # Linux, FreeBSD + if ($?) { $cmd = "netstat -rn -f $ipstr"; $reply = qx{ $cmd 2>/dev/null }; } # MacOS + if ($?) { $cmd = "netstat -rn"; $reply = qx{ $cmd 2>/dev/null }; } # Busybox + if ($?) { $cmd = "missing ip or netstat command"; + failed("Unable to obtain default route information -- %s", $cmd) + } + } + debug("Reply from '%s' :\n------\n%s------", $cmd, $reply); + + # Check we have IPv6 address in case we got routing table from non-specific cmd above + return undef if (($ipver == 6) && !extract_ipv6($reply)); + # Filter down to just the default interfaces + my @list = split(/\n/, $reply); + @list = grep(/^default|^(?:0\.){3}0|^::\/0/, @list); # Select 'default' or '0.0.0.0' or '::/0' + return undef if (scalar(@list) == 0); + debug("Default routes found for IPv%s :\n%s", $ipver, join("\n",@list)); + + # now check each interface to make sure it is global (not loopback). + foreach my $line (@list) { + ## Interface will be after "dev" or the last word in the line. Must accept blank spaces + ## at the end. Interface name may not have any whitespace or forward slash. + $line =~ /\bdev\b\s*\K[^\s\/]+|\b[^\s\/]+(?=[\s\/]*$)/; + my $interface = $&; + ## If test data was passed in skip following tests + if ($cmd ne "test") { + ## We do not want the loopback interface or anything interface without global scope + $cmd = "ip -$ipver -o addr show dev $interface scope global"; $reply = qx{$cmd 2>/dev/null}; + if ($?) { $cmd = "ifconfig $interface"; $reply = qx{$cmd 2>/dev/null}; } + if ($?) { $cmd = "missing ip or ifconfig command"; + failed("Unable to obtain information for '%s' -- %s", $interface, $cmd); + } + debug("Reply from '%s' :\n------\n%s------", $cmd, $reply); + } + ## Has global scope, is not LOOPBACK + return($interface) if (($reply) && ($reply !~ /\bLOOPBACK\b/)); + } + return undef; +} + +###################################################################### +## get_ip_from_interface() finds an IPv4 or IPv6 address from a network +## interface. Defaults to IPv4 unless '6' passed as 2nd parameter. +###################################################################### +sub get_ip_from_interface { + my $interface = shift // "default"; + my $ipver = int(shift // 4); ## Defaults to IPv4 if not specified + my $scope = lc(shift // "gua"); ## "gua" or "ula" + my $reply = shift // ''; ## Pass in data for unit testing purposes only + my $MacOS = shift // 0; ## For testing can set to 1 if input data is MacOS/FreeBSD format + my $count = 0; + my $cmd = "test"; + + if (($ipver != 4) && ($ipver != 6)) { + warning("get_ip_from_interface() invalid IP version: %s", $ipver); + return undef; + } + + if ((lc($interface) eq "default") && (!$reply)) { ## skip if test data passed in. + $interface = get_default_interface($ipver); + return undef if !defined($interface); + } + + if ($ipver == 4) { + if (!$reply) { ## skip if test data passed in. + ## Try ip first, then ifconfig. + $cmd = "ip -4 -o addr show dev $interface scope global"; $reply = qx{$cmd 2>/dev/null}; + if ($?) { $cmd = "ifconfig $interface"; $reply = qx{$cmd 2>/dev/null}; } + if ($?) { $cmd = "missing ip or ifconfig command"; + failed("Unable to obtain information for '%s' -- %s", $interface, $cmd); + } + } + debug("Reply from '%s' :\n------\n%s------", $cmd, $reply); + + ## IPv4 is simple, we just need to find the first IPv4 address returned in the list. + my @reply = split(/\n/, $reply); + @reply = grep(/\binet\b/, @reply); # Select only IPv4 entries + return extract_ipv4($reply[0]); + } + + ## From this point on we only looking for IPv6 address. + if (($scope ne "gua") && ($scope ne "ula")) { + warning("get_ip_from_interface() invalid IPv6 scope: %s, using type GUA", $scope); + $scope = "gua"; + } + + $cmd = "test data"; + if (!$reply) { ## skip if test data passed in. + ## Try ip first, then ifconfig with -L for MacOS/FreeBSD then finally ifconfig for everything else + $cmd = "ip -6 -o addr show dev $interface scope global"; $reply = qx{$cmd 2>/dev/null}; # Linux + if ($?) { $cmd = "ifconfig -L $interface"; $MacOS = 1; $reply = qx{$cmd 2>/dev/null}; } # MacOS/FreeBSD + if ($?) { $cmd = "ifconfig $interface"; $reply = qx{$cmd 2>/dev/null}; } # Anything without iproute2 or -L + if ($?) { $cmd = "missing ip or ifconfig command"; + failed("Unable to obtain information for '%s' -- %s", $interface, $cmd); + } + } + debug("Reply from '%s' :\n------\n%s------", $cmd, $reply); + + ## IPv6 is more complex than IPv4. Start by filtering on only "inet6" addresses + ## Then remove deprecated or temporary addresses and finally seleect on global or local addresses + my @reply = split(/\n/, $reply); + @reply = grep(/\binet6\b/, @reply); # Select only IPv6 entries + @reply = grep(!/\bdeprecated\b|\btemporary\b/, @reply); # Remove deprecated and temporary + @reply = ($scope eq "gua") ? grep(/$regex_ipv6_global/, @reply) # Select only global addresses + : grep(/$regex_ipv6_ula/, @reply); # or only ULA addresses + debug("Raw IPv6 after filtering for %s addresses %s: (%s)\r\n%s", uc($scope), $interface, scalar(@reply), join("\n", @reply)); + + ## If we filter down to zero or one result then we are done... + return undef if (($count = scalar(@reply)) == 0); + return extract_ipv6($reply[0]) if ($count == 1); + + ## If there are more than one we need to select the "best". + ## First choice would be a static address. + my @static = ($MacOS == 1) ? grep(!/^.*\bvltime\b.*$/i, @reply) # MacOS/FreeBSD, no 'vltime' + : grep(/^.*\bvalid_lft.\bforever\b.*$/i, @reply); # Everything else 'forever' life + $count = scalar(@static); + debug("Possible Static IP addresses %s: (%s)\r\n%s", $interface, $count, join("\n", @static)); + + ## If only one result then we are done. If there are more than one static addresses + ## then we will replace our original list with the list of statics and sort on them. + ## If zero static addresses we fall through with our original list. + return extract_ipv6($static[0]) if ($count == 1); + @reply = @static if ($count > 1); + + ## Sort what we have by the prefix length, IP address "length" and finally valid life. + my @sorted = sort { + ## We give preference to IP addressess with the longest prefix... so we prefer a /128 over a /64 + ## this is a decimal (\d+) either after the word "prefixlen" or after a forward slash. + (($b =~ /(?:\bprefixlen\b\s*|\/)(\d+)/i)[0] // 0) <=> (($a =~ /(?:\bprefixlen\b\s*|\/)(\d+)/i)[0] // 0) + + ## If there are multiple the same then we prefer "shorter" IP addresses in the + ## theory that a shorter address is more likely assigned by DHCPv6 than SLAAC. + ## E.g. 2001:db8:4341:0781::8214/64 is preferable to 2001:db8:4341:0781:34a6:c329:c52e:8ba6/64 + ## So we count the number () of groups of [0-9a-f] blocks in the IP address. + || (()= (extract_ipv6($a) // '') =~ /[0-9A-F]+/gi) <=> (()= (extract_ipv6($b) // '') =~ /[0-9A-F]+/gi) + + ## Finally we check remaining valid lifetime and prefer longer remaining life. + ## This is a desimal (\d+) after the word "valid_lft" or "vltime". Only available + ## from iproute2 or MacOS/FreeBSD version of ifconfig (-L parameter). + || (($b =~ /(?:\bvalid_lft\b\s*|\bvltime\b\s*)(\d+)/i)[0] // 0) <=> (($a =~ /(?:\bvalid_lft\b\s*|\bvltime\b\s*)(\d+)/i)[0] // 0) + } @reply; + debug("Sorted list of IP addresss for %s: (%s)\r\n%s", $interface, scalar(@sorted), join("\n", @sorted)); + + ## Whatever sorted to the top is the best choice for IPv6 address + return extract_ipv6($sorted[0]); +} + +###################################################################### +## get_ipv4 +###################################################################### +sub get_ipv4 { + my $usev4 = lc(shift); ## Method to obtain IP address + my $h = shift; ## Host/service making the request + + my $ipv4 = undef; ## Found IPv4 address + my $reply = ''; ## Text returned from various methods + my $url = ''; ## URL of website or firewall + my $skip = ''; ## Regex of pattern to skip before looking for IP + my $arg = opt($usev4, $h) // ''; ## Value assigned to the "usev4" method + + if ($usev4 eq 'ipv4') { + ## Static IPv4 address is provided in "ipv4=
" + $ipv4 = $arg; + if (!is_ipv4($ipv4)) { + warning("'%s' is not a valid IPv4",$ipv4 // ''); + $ipv4 = undef; + } + $arg = 'ipv4'; # For debug message at end of function + + } elsif ($usev4 eq 'ifv4') { + ## Obtain IPv4 address from interface mamed in "ifv4=" + warning("'if-skip' is deprecated and does nothing for IPv4") if (opt('verbose') && opt('if-skip', $h)); + $ipv4 = get_ip_from_interface($arg,4); + + } elsif ($usev4 eq 'cmdv4') { + ## Obtain IPv4 address by executing the command in "cmdv4=" + warning("'cmd-skip' is deprecated and does nothing for IPv4") if (opt('verbose') && opt('cmd-skip', $h)); + if ($arg) { + my $sys_cmd = quotemeta($arg); + $reply = qx{$sys_cmd}; + $reply = '' if $?; + } + + } elsif ($usev4 eq 'webv4') { + ## Obtain IPv4 address by accessing website at url in "webv4=" + $url = $arg; + $skip = opt('webv4-skip', $h) // ''; + if (exists $builtinweb{$url}) { + $skip = $builtinweb{$url}->{'skip'} unless $skip; + $url = $builtinweb{$url}->{'url'}; + $arg = $url; + } + if ($url) { + $reply = geturl( proxy => opt('proxy', $h), + url => $url, + ipversion => 4, # when using a URL to find IPv4 address we should force use of IPv4 + ssl_validate => opt('ssl-validate', $h), + ) // ''; + } + + } elsif ($usev4 eq 'cisco' || $usev4 eq 'cisco-asa') { + # Stuff added to support Cisco router ip http or ASA https daemon + # User fw-login should only have level 1 access to prevent + # password theft. This is pretty harmless. + warning("'if' does nothing for IPv4. Use 'ifv4'") if (opt('if', $h)); + warning("'fw' does nothing for IPv4. Use 'fwv4'") if (opt('fw', $h)); + warning("'fw-skip' does nothing for IPv4. Use 'fwv4-skip'") if (opt('fw-skip', $h)); + my $queryif = opt('ifv4', $h) // opt('if', $h); + $skip = opt('fwv4-skip', $h) // opt('fw-skip', $h) // ''; + # Convert slashes to protected value "\/" + $queryif =~ s%\/%\\\/%g; + # Protect special HTML characters (like '?') + $queryif =~ s/([\?&= ])/sprintf("%%%02x", ord($1))/ge; + if ($usev4 eq 'cisco') { + $url = "http://" . (opt('fwv4', $h) // opt('fw', $h)) . "/level/1/exec/show/ip/interface/brief/${queryif}/CR"; + } else { + $url = "https://" . (opt('fwv4', $h) // opt('fw', $h)) . "/exec/show%20interface%20${queryif}"; + } + $arg = $url; + $reply = geturl( + url => $url, + login => opt('fw-login', $h), + password => opt('fw-password', $h), + ipversion => 4, # when using a URL to find IPv4 address we should force use of IPv4 + ignore_ssl_option => 1, + ssl_validate => opt('ssl-validate', $h), + ) // ''; + + } elsif ($usev4 eq 'disabled') { + ## This is a no-op... Do not get an IPv4 address for this host/service + $reply = ''; + + } else { + warning("'fw' does nothing for IPv4. Use 'fwv4'") if (opt('fw', $h)); + warning("'fw-skip' does nothing for IPv4. Use 'fwv4-skip'") if (opt('fw-skip', $h)); + $url = opt('fwv4', $h) // opt('fw', $h) // ''; + $skip = opt('fwv4-skip', $h) // opt('fw-skip', $h) // ''; + + if (exists $builtinfw{$usev4}) { + $skip = $builtinfw{$usev4}->{'skip'} unless $skip; + $url = "http://${url}" . $builtinfw{$usev4}->{'url'} unless $url =~ /\//; + } + $arg = $url; + if ($url) { + $reply = geturl( + url => $url, + login => opt('fw-login', $h), + password => opt('fw-password', $h), + ipversion => 4, # when using a URL to find IPv4 address we should force use of IPv4 + ignore_ssl_option => 1, + ssl_validate => opt('ssl-validate', $h), + ) // ''; + } + } + + ## Set to loopback address if no text set yet + $reply = '0.0.0.0' if !defined($reply); + if (($skip // '') ne '') { + $skip =~ s/ /\\s/is; + $reply =~ s/^.*?${skip}//is; + } + ## If $ipv4 not set yet look for IPv4 address in the $reply text + $ipv4 //= extract_ipv4($reply); + ## Return undef for loopback address unless statically assigned by "ipv4=0.0.0.0" + $ipv4 = undef if (($usev4 ne 'ipv4') && (($ipv4 // '') eq '0.0.0.0')); + debug("get_ipv4: using (%s, %s) reports %s", $usev4, $arg, $ipv4 // ""); + return $ipv4; +} + +###################################################################### +## get_ipv6 +###################################################################### +sub get_ipv6 { + my $usev6 = lc(shift); ## Method to obtain IP address + $usev6 = 'disabled' if ($usev6 eq 'no'); # backward compatibility + my $h = shift; ## Host/service making the request + + my $ipv6 = undef; ## Found IPv6 address + my $reply = ''; ## Text returned from various methods + my $url = ''; ## URL of website or firewall + my $skip = ''; ## Regex of pattern to skip before looking for IP + my $arg = opt($usev6, $h) // ''; ## Value assigned to the "usev6" method + + if ($usev6 eq 'ipv6' || $usev6 eq 'ip') { + ## Static IPv6 address is provided in "ipv6=
" + if ($usev6 eq 'ip') { + warning("'usev6=ip' is deprecated. Use 'usev6=ipv6'"); + $usev6 = 'ipv6'; + ## If there is a value for ipv6= use that, else use value for ip= + $arg = opt($usev6, $h) // $arg; + } + $ipv6 = $arg; + if (!is_ipv6($ipv6)) { + warning("'%s' is not a valid IPv6",$ipv6 // ''); + $ipv6 = undef; + } + $arg = 'ipv6'; # For debug message at end of function + + } elsif ($usev6 eq 'ifv6' || $usev6 eq 'if' ) { + ## Obtain IPv6 address from interface mamed in "ifv6=" + if ($usev6 eq 'if') { + warning("'usev6=if' is deprecated. Use 'usev6=ifv6'"); + $usev6 = 'ifv6'; + ## If there is a value for ifv6= use that, else use value for if= + $arg = opt($usev6, $h) // $arg; + } + warning("'if-skip' is deprecated and does nothing for IPv6") if (opt('verbose') && opt('if-skip', $h)); + $ipv6 = get_ip_from_interface($arg,6); + + } elsif ($usev6 eq 'cmdv6' || $usev6 eq 'cmd') { + ## Obtain IPv6 address by executing the command in "cmdv6=" + if ($usev6 eq 'cmd') { + warning("'usev6=cmd' is deprecated. Use 'usev6=cmdv6'"); + $usev6 = 'cmdv6'; + ## If there is a value for cmdv6= use that, else use value for cmd= + $arg = opt($usev6, $h) // $arg; + } + warning("'cmd-skip' is deprecated and does nothing for IPv6") if (opt('verbose') && opt('cmd-skip', $h)); + if ($arg) { + my $sys_cmd = quotemeta($arg); + $reply = qx{$sys_cmd}; + $reply = '' if $?; + } + + } elsif ($usev6 eq 'webv6' || $usev6 eq 'web') { + ## Obtain IPv6 address by accessing website at url in "webv6=" + if ($usev6 eq 'web') { + warning("'usev6=web' is deprecated. Use 'usev6=webv6'"); + $usev6 = 'webv6'; + ## If there is a value for webv6= use that, else use value for web= + $arg = opt($usev6, $h) // $arg; + } + warning("'web-skip' does nothing for IPv6. Use 'webv6-skip'") if (opt('web-skip', $h)); + $url = $arg; + $skip = opt('webv6-skip', $h) // ''; + if (exists $builtinweb{$url}) { + $skip = $builtinweb{$url}->{'skip'} unless $skip; + $url = $builtinweb{$url}->{'url'}; + $arg = $url; + } + if ($url) { + $reply = geturl( + proxy => opt('proxy'), + url => $url, + ipversion => 6, # when using a URL to find IPv6 address we should force use of IPv6 + ssl_validate => opt('ssl-validate', $h), + ) // ''; + } + + } elsif ($usev6 eq 'cisco' || $usev6 eq 'cisco-asa') { + warning("'usev6=cisco' and 'usev6=cisco-asa' are not implemented and do nothing"); + $reply = ''; + + } elsif ($usev6 eq 'disabled') { + ## This is a no-op... Do not get an IPv6 address for this host/service + warning("'usev6=no' is deprecated. Use 'usev6=disabled'") if ($usev6 eq 'no'); + $reply = ''; + + } else { + warning("'usev6=%s' is not implemented and does nothing", $usev6); + $reply = ''; + + } + + ## Set to loopback address if no text set yet + $reply = '::' if !defined($reply); + if (($skip // '') ne '') { + $skip =~ s/ /\\s/is; + $reply =~ s/^.*?${skip}//is; + } + ## If $ipv6 not set yet look for IPv6 address in the $reply text + $ipv6 //= extract_ipv6($reply); + ## Return undef for loopback address unless statically assigned by "ipv6=::" + $ipv6 = undef if (($usev6 ne 'ipv6') && (($ipv6 // '') eq '::')); + debug("get_ipv6: using (%s, %s) reports %s", $usev6, $arg, $ipv6 // ""); + return $ipv6; +} + +###################################################################### +## group_hosts_by +###################################################################### +sub group_hosts_by { +##TODO - Update for wantipv4 and wantipv6 + my ($hosts, $attributes) = @_; + my %attrs = (map({ ($_ => 1) } @$attributes), 'wantip' => 1); + my @attrs = sort(keys(%attrs)); + my %groups = (); + foreach my $h (@$hosts) { + my $sig = join(',', map({ sprintf("%s=%s", $_, $config{$h}{$_} // '') } @attrs)); + push @{$groups{$sig}}, $h; + } + return %groups; +} + +###################################################################### +## encode_www_form_urlencoded +###################################################################### +sub encode_www_form_urlencoded { + my $formdata = shift; + + my $must_encode = qr'[<>"#%{}|\\^~\[\]`;/?:=&+]'; + my $encoded; + my $i = 0; + foreach my $k (keys %$formdata) { + my $kenc = $k; + my $venc = $formdata->{$k}; + + $kenc =~ s/($must_encode)/sprintf('%%%02X', ord($1))/ge; + $venc =~ s/($must_encode)/sprintf('%%%02X', ord($1))/ge; + + $kenc =~ s/ /+/g; + $venc =~ s/ /+/g; + + $encoded .= $kenc . '=' . $venc; + if ($i < (keys %$formdata) - 1) { + $encoded .= '&'; + } + $i++; + } + + return $encoded; +} + +###################################################################### +## nic_examples +###################################################################### +sub nic_examples { + my $examples = ""; + my $separator = ""; + foreach my $s (sort keys %services) { + my $subr = $services{$s}{'examples'}; + my $example; + + if (defined($subr) && ($example = &$subr())) { + chomp($example); + $examples .= $example; + $examples .= "\n\n$separator"; + $separator = "\n"; + } + } + my $intro = <<"EoEXAMPLE"; +== CONFIGURING ${program} + +The configuration file, ${program}.conf, can be used to define the +default behaviour and operation of ${program}. The file consists of +sequences of global variable definitions and host definitions. + +Global definitions look like: + name=value [,name=value]* + +For example: + daemon=5m + use=if, if=eth0 + proxy=proxy.myisp.com + protocol=dyndns2 + +specifies that ${program} should operate as a daemon, checking the +eth0 interface for an IP address change every 5 minutes and use the +'dyndns2' protocol by default. The daemon interval can be specified +as seconds (600s), minutes (5m), hours (1h) or days (1d). + +Host definitions look like: + [name=value [,name=value]*]* a.host.domain [,b.host.domain] [login] [password] + +For example: + protocol=noip, \\ + login=your-username, password=your-password myhost.noip.com + login=your-username, password=your-password myhost.noip.com,myhost2.noip.com + +specifies two host definitions. + +The first definition will use the noip protocol, +your-username and your-password to update the ip-address of +myhost.noip.com and my2ndhost.noip.com. + +The second host definition will use the current default protocol +('dyndns2'), my-login and my-password to update the ip-address of +myhost.dyndns.org and my2ndhost.dyndns.org. + +The order of this sequence is significant because the values of any +global variable definitions are bound to a host definition when the +host definition is encountered. + +See the sample-${program}.conf file for further examples. +EoEXAMPLE + $intro .= "\n== NIC specific variables and examples:\n$examples" if $examples; + return $intro; +} +###################################################################### +## nic_updateable +## Returns true if we can go ahead and update the IP address at server +###################################################################### +sub nic_updateable { + my $host = shift; + my $sub = shift; + my $update = 0; + my $ip = $config{$host}{'wantip'}; + my $ipv4 = $config{$host}{'wantipv4'}; + my $ipv6 = $config{$host}{'wantipv6'}; + my $use = opt('use', $host) // 'disabled'; + my $usev4 = opt('usev4', $host) // 'disabled'; + my $usev6 = opt('usev6', $host) // 'disabled'; + $use = 'disabled' if ($use eq 'no'); # backward compatibility + $usev6 = 'disabled' if ($usev6 eq 'no'); # backward compatibility + + # If we have a valid IP address and we have previously warned that it was invalid. + # reset the warning count back to zero. + if (($use ne 'disabled') && $ip && $warned_ip{$host}) { + $warned_ip{$host} = 0; + warning("IP address for %s valid: %s. Reset warning count", $host, $ip); + } + if (($usev4 ne 'disabled') && $ipv4 && $warned_ipv4{$host}) { + $warned_ipv4{$host} = 0; + warning("IPv4 address for %s valid: %s. Reset warning count", $host, $ipv4); + } + if (($usev6 ne 'disabled') && $ipv6 && $warned_ipv6{$host}) { + $warned_ipv6{$host} = 0; + warning("IPv6 address for %s valid: %s. Reset warning count", $host, $ipv6); + } + + if ($config{$host}{'login'} eq '') { + warning("null login name specified for host %s.", $host); + + } elsif ($config{$host}{'password'} eq '') { + warning("null password specified for host %s.", $host); + + } elsif ($opt{'force'}) { + info("forcing update of %s.", $host); + $update = 1; + + } elsif (!exists($cache{$host})) { + info("forcing updating %s because no cached entry exists.", $host); + $update = 1; + + } elsif ($cache{$host}{'wtime'} && $cache{$host}{'wtime'} > $now) { + warning("cannot update %s from %s to %s until after %s.", + $host, + ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), $ip, + prettytime($cache{$host}{'wtime'}) + ); + + } elsif ($cache{$host}{'mtime'} && interval_expired($host, 'mtime', 'max-interval')) { + warning("forcing update of %s from %s to %s; %s since last update on %s.", + $host, + ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), $ip, + prettyinterval($config{$host}{'max-interval'}), + prettytime($cache{$host}{'mtime'}) + ); + $update = 1; + + } elsif ( ($use ne 'disabled') + && ((!exists($cache{$host}{'ip'})) || ("$cache{$host}{'ip'}" ne "$ip"))) { + ## Check whether to update IP address for the "use" method" + if (($cache{$host}{'status'} eq 'good') && + !interval_expired($host, 'mtime', 'min-interval')) { + + warning("skipping update of %s from %s to %s.\nlast updated %s.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), + $ip, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + prettyinterval($config{$host}{'min-interval'}) + ) + if opt('verbose') || !($cache{$host}{'warned-min-interval'} // 0); + + $cache{$host}{'warned-min-interval'} = $now; + + } elsif (($cache{$host}{'status'} ne 'good') && + !interval_expired($host, 'atime', 'min-error-interval')) { + + if ( opt('verbose') + || ( ! $cache{$host}{'warned-min-error-interval'} + && (($warned_ip{$host} // 0) < $inv_ip_warn_count)) ) { + + warning("skipping update of %s from %s to %s.\nlast updated %s but last attempt on %s failed.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ip'} ? $cache{$host}{'ip'} : ''), + $ip, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + ($cache{$host}{'atime'} ? prettytime($cache{$host}{'atime'}) : ''), + prettyinterval($config{$host}{'min-error-interval'}) + ); + if (!$ip && !opt('verbose')) { + $warned_ip{$host} = ($warned_ip{$host} // 0) + 1; + warning("IP address for %s undefined. Warned %s times, suppressing further warnings", $host, $inv_ip_warn_count) + if ($warned_ip{$host} >= $inv_ip_warn_count); + } + } + + $cache{$host}{'warned-min-error-interval'} = $now; + + } else { + $update = 1; + } + + } elsif ( ($usev4 ne 'disabled') + && ((!exists($cache{$host}{'ipv4'})) || ("$cache{$host}{'ipv4'}" ne "$ipv4"))) { + ## Check whether to update IPv4 address for the "usev4" method" + if (($cache{$host}{'status-ipv4'} eq 'good') && + !interval_expired($host, 'mtime', 'min-interval')) { + + warning("skipping update of %s from %s to %s.\nlast updated %s.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ipv4'} ? $cache{$host}{'ipv4'} : ''), + $ipv4, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + prettyinterval($config{$host}{'min-interval'}) + ) + if opt('verbose') || !($cache{$host}{'warned-min-interval'} // 0); + + $cache{$host}{'warned-min-interval'} = $now; + + } elsif (($cache{$host}{'status-ipv4'} ne 'good') && + !interval_expired($host, 'atime', 'min-error-interval')) { + + if ( opt('verbose') + || ( ! $cache{$host}{'warned-min-error-interval'} + && (($warned_ipv4{$host} // 0) < $inv_ip_warn_count)) ) { + + warning("skipping update of %s from %s to %s.\nlast updated %s but last attempt on %s failed.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ipv4'} ? $cache{$host}{'ipv4'} : ''), + $ipv4, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + ($cache{$host}{'atime'} ? prettytime($cache{$host}{'atime'}) : ''), + prettyinterval($config{$host}{'min-error-interval'}) + ); + if (!$ipv4 && !opt('verbose')) { + $warned_ipv4{$host} = ($warned_ipv4{$host} // 0) + 1; + warning("IPv4 address for %s undefined. Warned %s times, suppressing further warnings", $host, $inv_ip_warn_count) + if ($warned_ipv4{$host} >= $inv_ip_warn_count); + } + } + + $cache{$host}{'warned-min-error-interval'} = $now; + + } else { + $update = 1; + } + + } elsif ( ($usev6 ne 'disabled') + && ((!exists($cache{$host}{'ipv6'})) || ("$cache{$host}{'ipv6'}" ne "$ipv6"))) { + ## Check whether to update IPv6 address for the "usev6" method" + if (($cache{$host}{'status-ipv6'} eq 'good') && + !interval_expired($host, 'mtime', 'min-interval')) { + + warning("skipping update of %s from %s to %s.\nlast updated %s.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ipv6'} ? $cache{$host}{'ipv6'} : ''), + $ipv6, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + prettyinterval($config{$host}{'min-interval'}) + ) + if opt('verbose') || !($cache{$host}{'warned-min-interval'} // 0); + + $cache{$host}{'warned-min-interval'} = $now; + + } elsif (($cache{$host}{'status-ipv6'} ne 'good') && + !interval_expired($host, 'atime', 'min-error-interval')) { + + if ( opt('verbose') + || ( ! $cache{$host}{'warned-min-error-interval'} + && (($warned_ipv6{$host} // 0) < $inv_ip_warn_count)) ) { + + warning("skipping update of %s from %s to %s.\nlast updated %s but last attempt on %s failed.\nWait at least %s between update attempts.", + $host, + ($cache{$host}{'ipv6'} ? $cache{$host}{'ipv6'} : ''), + $ipv6, + ($cache{$host}{'mtime'} ? prettytime($cache{$host}{'mtime'}) : ''), + ($cache{$host}{'atime'} ? prettytime($cache{$host}{'atime'}) : ''), + prettyinterval($config{$host}{'min-error-interval'}) + ); + if (!$ipv6 && !opt('verbose')) { + $warned_ipv6{$host} = ($warned_ipv6{$host} // 0) + 1; + warning("IPv6 address for %s undefined. Warned %s times, suppressing further warnings", $host, $inv_ip_warn_count) + if ($warned_ipv6{$host} >= $inv_ip_warn_count); + } + } + + $cache{$host}{'warned-min-error-interval'} = $now; + + } else { + $update = 1; + } + + } elsif (defined($sub) && &$sub($host)) { + $update = 1; + } elsif ((defined($cache{$host}{'static'}) && defined($config{$host}{'static'}) && + ($cache{$host}{'static'} ne $config{$host}{'static'})) || + (defined($cache{$host}{'wildcard'}) && defined($config{$host}{'wildcard'}) && + ($cache{$host}{'wildcard'} ne $config{$host}{'wildcard'})) || + (defined($cache{$host}{'mx'}) && defined($config{$host}{'mx'}) && + ($cache{$host}{'mx'} ne $config{$host}{'mx'})) || + (defined($cache{$host}{'backupmx'}) && defined($config{$host}{'backupmx'}) && + ($cache{$host}{'backupmx'} ne $config{$host}{'backupmx'}))) { + info("updating %s because host settings have been changed.", $host); + $update = 1; + + } else { + if (opt('verbose')) { + if ($use ne 'disabled') { + success("%s: skipped: IP address was already set to %s.", $host, $ip); + } + if ($usev4 ne 'disabled') { + success("%s: skipped: IPv4 address was already set to %s.", $host, $ipv6); + } + if ($usev6 ne 'disabled') { + success("%s: skipped: IPv6 address was already set to %s.", $host, $ipv6); + } + } + } + + $config{$host}{'status'} = $cache{$host}{'status'} // ''; + $config{$host}{'status-ipv4'} = $cache{$host}{'status-ipv4'} // ''; + $config{$host}{'status-ipv6'} = $cache{$host}{'status-ipv6'} // ''; + $config{$host}{'update'} = $update; + if ($update) { + $config{$host}{'status'} = 'noconnect'; + $config{$host}{'status-ipv4'} = 'noconnect'; + $config{$host}{'status-ipv6'} = 'noconnect'; + $config{$host}{'atime'} = $now; + $config{$host}{'wtime'} = 0; + $config{$host}{'warned-min-interval'} = 0; + $config{$host}{'warned-min-error-interval'} = 0; + + delete $cache{$host}{'warned-min-interval'}; + delete $cache{$host}{'warned-min-error-interval'}; + } + + return $update; +} + +###################################################################### +## header_ok +###################################################################### +sub header_ok { + my ($host, $line) = @_; + my $ok = 0; + + if ($line =~ m%^s*HTTP/.*\s+(\d+)%i) { + my $result = $1; + + if ($result =~ m/^2\d\d$/) { + $ok = 1; + + } elsif ($result eq '401') { + failed("updating %s: authorization failed (%s)", $host, $line); + } + + } else { + failed("updating %s: unexpected line (%s)", $host, $line); + } + return $ok; +} +###################################################################### +## nic_dyndns1_examples +###################################################################### +sub nic_dyndns1_examples { + return <<"EoEXAMPLE"; +o 'dyndns1' + +The 'dyndns1' protocol is a deprecated protocol used by the free dynamic +DNS service offered by www.dyndns.org. The 'dyndns2' should be used to +update the www.dyndns.org service. However, other services are also +using this protocol so support is still provided by ${program}. + +Configuration variables applicable to the 'dyndns1' protocol are: + protocol=dyndns1 ## + server=fqdn.of.service ## defaults to members.dyndns.org + backupmx=no|yes ## indicates that this host is the primary MX for the domain. + mx=any.host.domain ## a host MX'ing for this host definition. + wildcard=no|yes ## add a DNS wildcard CNAME record that points to {host} + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=dyndns1, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password \\ + myhost.dyndns.org + + ## multiple host update with wildcard'ing mx, and backupmx + protocol=dyndns1, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password, \\ + mx=a.host.willing.to.mx.for.me,backupmx=yes,wildcard=yes \\ + myhost.dyndns.org,my2ndhost.dyndns.org +EoEXAMPLE +} +###################################################################### +## nic_dyndns1_update +###################################################################### +sub nic_dyndns1_update { + debug("\nnic_dyndns1_update -------------------"); + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + my $url; + $url = "https://$config{$h}{'server'}/nic/"; + $url .= ynu($config{$h}{'static'}, 'statdns', 'dyndns', 'dyndns'); + $url .= "?action=edit&started=1&hostname=YES&host_id=$h"; + $url .= "&myip="; + $url .= $ip if $ip; + $url .= "&wildcard=ON" if ynu($config{$h}{'wildcard'}, 1, 0, 0); + if ($config{$h}{'mx'}) { + $url .= "&mx=$config{$h}{'mx'}"; + $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); + } + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my ($title, $return_code, $error_code) = ('', '', ''); + foreach my $line (@reply) { + $title = $1 if $line =~ m%\s*(.*)\s*%i; + $return_code = $1 if $line =~ m%^return\s+code\s*:\s*(.*)\s*$%i; + $error_code = $1 if $line =~ m%^error\s+code\s*:\s*(.*)\s*$%i; + } + + if ($return_code ne 'NOERROR' || $error_code ne 'NOERROR' || !$title) { + $config{$h}{'status'} = 'failed'; + $title = "incomplete response from $config{$h}{server}" unless $title; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: %s", $h, $title); + + } else { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: %s: IP address set to %s (%s)", $h, $return_code, $ip, $title); + } + } +} +###################################################################### +## nic_dyndns2_updateable +###################################################################### +sub nic_dyndns2_updateable { + my $host = shift; + my $update = 0; + + if ($config{$host}{'mx'} ne $cache{$host}{'mx'}) { + info("forcing updating %s because 'mx' has changed to %s.", $host, $config{$host}{'mx'}); + $update = 1; + + } elsif ($config{$host}{'mx'} && (ynu($config{$host}{'backupmx'}, 1, 2, 3) ne ynu($config{$host}{'backupmx'}, 1, 2, 3))) { + info("forcing updating %s because 'backupmx' has changed to %s.", $host, ynu($config{$host}{'backupmx'}, "YES", "NO", "NO")); + $update = 1; + + } elsif ($config{$host}{'static'} ne $cache{$host}{'static'}) { + + info("forcing updating %s because 'static' has changed to %s.", $host, ynu($config{$host}{'static'}, "YES", "NO", "NO")); + $update = 1; + + } + return $update; +} +###################################################################### +## nic_dyndns2_examples +###################################################################### +sub nic_dyndns2_examples { + return <<"EoEXAMPLE"; +o 'dyndns2' + +The 'dyndns2' protocol is a newer low-bandwidth protocol used by a +free dynamic DNS service offered by www.dyndns.org. It supports +features of the older 'dyndns1' in addition to others. [These will be +supported in a future version of ${program}.] + +Configuration variables applicable to the 'dyndns2' protocol are: + protocol=dyndns2 ## + server=fqdn.of.service ## defaults to members.dyndns.org + script=/path/to/script ## defaults to /nic/update + backupmx=no|yes ## indicates that this host is the primary MX for the domain. + static=no|yes ## indicates that this host has a static IP address. + custom=no|yes ## indicates that this host is a 'custom' top-level domain name. + mx=any.host.domain ## a host MX'ing for this host definition. + wildcard=no|yes ## add a DNS wildcard CNAME record that points to {host} + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=dyndns2, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password \\ + myhost.dyndns.org + + ## multiple host update with wildcard'ing mx, and backupmx + protocol=dyndns2, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password, \\ + mx=a.host.willing.to.mx.for.me,backupmx=yes,wildcard=yes \\ + myhost.dyndns.org,my2ndhost.dyndns.org + + ## multiple host update to the custom DNS service + protocol=dyndns2, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_dyndns2_update +###################################################################### +sub nic_dyndns2_update { + debug("\nnic_dyndns2_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(login password server static custom wildcard mx backupmx) ]); + + my %errors = ( + 'badauth' => 'Bad authorization (username or password)', + 'badsys' => 'The system parameter given was not valid', + + 'notfqdn' => 'A Fully-Qualified Domain Name was not provided', + 'nohost' => 'The hostname specified does not exist in the database', + '!yours' => 'The hostname specified exists, but not under the username currently being used', + '!donator' => 'The offline setting was set, when the user is not a donator', + '!active' => 'The hostname specified is in a Custom DNS domain which has not yet been activated.', + 'abuse', => 'The hostname specified is blocked for abuse; you should receive an email notification ' . + 'which provides an unblock request link. More info can be found on ' . + 'https://www.dyndns.com/support/abuse.html', + + 'numhost' => 'System error: Too many or too few hosts found. Contact support@dyndns.org', + 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', + + 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', + ); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $h = $hosts[0]; + my $ip = $config{$h}{'wantip'}; + delete $config{$_}{'wantip'} foreach @hosts; + + info("setting IP address to %s for %s", $ip, $hosts); + verbose("UPDATE:", "updating %s", $hosts); + + ## Select the DynDNS system to update + my $url = "http://$config{$h}{'server'}$config{$h}{'script'}?system="; + if ($config{$h}{'custom'}) { + warning("updating %s: 'custom' and 'static' may not be used together. ('static' ignored)", $hosts) + if $config{$h}{'static'}; + $url .= 'custom'; + + } elsif ($config{$h}{'static'}) { + $url .= 'statdns'; + + } else { + $url .= 'dyndns'; + } + + $url .= "&hostname=$hosts"; + $url .= "&myip="; + $url .= $ip if $ip; + + ## some args are not valid for a custom domain. + $url .= "&wildcard=ON" if ynu($config{$h}{'wildcard'}, 1, 0, 0); + if ($config{$h}{'mx'}) { + $url .= "&mx=$config{$h}{'mx'}"; + $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); + } + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); + next; + } + next if !header_ok($hosts, $reply); + + my @reply = split /\n/, $reply; + my $state = 'header'; + my $returnedip = $ip; + + foreach my $line (@reply) { + if ($state eq 'header') { + $state = 'body'; + + } elsif ($state eq 'body') { + $state = 'results' if $line eq ''; + + } elsif ($state =~ /^results/) { + $state = 'results2'; + + # bug #10: some dyndns providers does not return the IP so + # we can't use the returned IP + my ($status, $returnedip) = split / /, lc $line; + $ip = $returnedip if (not $ip); + my $h = shift @hosts; + + $config{$h}{'status'} = $status; + if ($status eq 'good') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + success("updating %s: %s: IP address set to %s", $h, $status, $ip); + + } elsif (exists $errors{$status}) { + if ($status eq 'nochg') { + warning("updating %s: %s: %s", $h, $status, $errors{$status}); + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + + } else { + failed("updating %s: %s: %s", $h, $status, $errors{$status}); + } + + } elsif ($status =~ /w(\d+)(.)/) { + my ($wait, $units) = ($1, lc $2); + my ($sec, $scale) = ($wait, 1); + + ($scale, $units) = (1, 'seconds') if $units eq 's'; + ($scale, $units) = (60, 'minutes') if $units eq 'm'; + ($scale, $units) = (60*60, 'hours') if $units eq 'h'; + + $sec = $wait * $scale; + $config{$h}{'wtime'} = $now + $sec; + warning("updating %s: %s: wait %s %s before further updates", $h, $status, $wait, $units); + + } else { + failed("updating %s: unexpected status (%s)", $h, $line); + } + } + } + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) + if $state ne 'results2'; + } +} + +###################################################################### +## nic_dnsexit_examples +###################################################################### +sub nic_dnsexit_examples { + return <<"EoEXAMPLE"; +o 'dnsexit' + +The 'dnsexit' protocol is the protocol used by the dynamic hostname services +of the 'DnsExit' dns services. This is currently used by the free +dynamic DNS service offered by www.dnsexit.com. + +Configuration variables applicable to the 'dnsexit' protocol are: + ssl=no ## turn off ssl + protocol=dnsexit ## + server=update.dnsexit.com ## defaults to update.dnsexit.com + use=web ## defaults to web + web=update.dnsexit.com ## defaults to update.dnsexit.com + script=/RemoteUpdate.sv ## defaults to /RemoteUpdate.sv + login=service-userid ## userid registered with the service + password=service-password ## password registered with the service + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=dnsexit \\ + login=service-userid \\ + password=service-password \\ + fully.qualified.host + +EoEXAMPLE +} +###################################################################### +## nic_dnsexit_update +## +## written by Gonzalo Pérez de Olaguer Córdoba +## +## based on https://www.dnsexit.com/Direct.sv?cmd=ipClients +## fetches this URL to update: +## https://update.dnsexit.com/RemoteUpdate.sv?login=yourlogin&password=yourpassword& +## host=yourhost.yourdomain.com&myip=xxx.xx.xx.xxx +## +###################################################################### +sub nic_dnsexit_update { + debug("\nnic_dnsexit_update -------------------"); + + my %status = ( + '0' => [ 'good', 'Success' ], + '1' => [ 'nochg', 'IP is the same as the IP on the system' ], + '2' => [ 'badauth', 'Invalid password' ], + '3' => [ 'badauth', 'User not found' ], + '4' => [ 'nochg', 'IP not changed. To save our system resources, please don\'t post updates unless the IP got changed.' ], + '10' => [ 'error', 'Hostname is not specified' ], + '11' => [ 'nohost', 'fail to find the domain' ], + '13' => [ 'error', 'parameter validation error' ], + ); + + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:","updating %s", $h); + + # Set the URL that we're going to update + my $url; + $url = "https://$config{$h}{'server'}$config{$h}{'script'}"; + $url .= "?login=$config{$h}{'login'}"; + $url .= "&password=$config{$h}{'password'}"; + $url .= "&host=$h"; + $url .= "&myip="; + $url .= $ip if $ip; + + # Try to get URL + my $reply = geturl( + proxy => opt('proxy'), + url => $url + ); + + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + last; + } + last if !header_ok($h, $reply); + + # Response found + if ($reply =~ /(\d+)=(.+)/) { + my ($statuscode, $statusmsg) = ($1, $2); + if (exists $status{$statuscode}) { + my ($status, $message) = @{ $status{$statuscode} }; + if ($status =~ m'^(good|nochg)$') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + } + $config{$h}{'status'} = $status; + if ($status eq 'good') { + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + warning("updating %s: %s: %s", $h, $status, $message); + } + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: failed: unrecognized status code (%s)", $h, $statuscode); + } + } else { + $config{$h}{'status'} = 'failed'; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: unrecognized reply.", $h); + } + } +} +###################################################################### +## nic_noip_update +## Note: uses same features as nic_dyndns2_update, less return codes +###################################################################### +sub nic_noip_update { + debug("\nnic_noip_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(login password server static custom wildcard mx backupmx) ]); + + my %errors = ( + 'badauth' => 'Invalid username or password', + 'badagent' => 'Invalid user agent', + 'nohost' => 'The hostname specified does not exist in the database', + '!donator' => 'The offline setting was set, when the user is not a donator', + 'abuse', => 'The hostname specified is blocked for abuse; open a trouble ticket at http://www.no-ip.com', + 'numhost' => 'System error: Too many or too few hosts found. open a trouble ticket at http://www.no-ip.com', + 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', + 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', + ); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $h = $hosts[0]; + my $ip = $config{$h}{'wantip'}; + delete $config{$_}{'wantip'} foreach @hosts; + + info("setting IP address to %s for %s", $ip, $hosts); + verbose("UPDATE:", "updating %s", $hosts); + + my $url = "https://$config{$h}{'server'}/nic/update?system="; + $url .= 'noip'; + $url .= "&hostname=$hosts"; + $url .= "&myip="; + $url .= $ip if $ip; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); + next; + } + next if !header_ok($hosts, $reply); + + my @reply = split /\n/, $reply; + my $state = 'header'; + foreach my $line (@reply) { + if ($state eq 'header') { + $state = 'body'; + + } elsif ($state eq 'body') { + $state = 'results' if $line eq ''; + + } elsif ($state =~ /^results/) { + $state = 'results2'; + + my ($status, $ip) = split / /, lc $line; + my $h = shift @hosts; + + $config{$h}{'status'} = $status; + if ($status eq 'good') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + success("updating %s: %s: IP address set to %s", $h, $status, $ip); + + } elsif (exists $errors{$status}) { + if ($status eq 'nochg') { + warning("updating %s: %s: %s", $h, $status, $errors{$status}); + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + + } else { + failed("updating %s: %s: %s", $h, $status, $errors{$status}); + } + + } elsif ($status =~ /w(\d+)(.)/) { + my ($wait, $units) = ($1, lc $2); + my ($sec, $scale) = ($wait, 1); + + ($scale, $units) = (1, 'seconds') if $units eq 's'; + ($scale, $units) = (60, 'minutes') if $units eq 'm'; + ($scale, $units) = (60*60, 'hours') if $units eq 'h'; + + $sec = $wait * $scale; + $config{$h}{'wtime'} = $now + $sec; + warning("updating %s: %s: wait %s %s before further updates", $h, $status, $wait, $units); + + } else { + failed("updating %s: unexpected status (%s)", $h, $line); + } + } + } + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) + if $state ne 'results2'; + } +} +###################################################################### +## nic_noip_examples +###################################################################### +sub nic_noip_examples { + return <<"EoEXAMPLE"; +o 'noip' + +The 'No-IP Compatible' protocol is used to make dynamic dns updates +over an http request. Details of the protocol are outlined at: +https://www.noip.com/integrate/ + +Configuration variables applicable to the 'noip' protocol are: + protocol=noip ## + server=fqdn.of.service ## defaults to dynupdate.no-ip.com + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=noip, \\ + login=userlogin\@domain.com, \\ + password=noip-password \\ + myhost.no-ip.biz + + +EoEXAMPLE +} +###################################################################### +## nic_dslreports1_examples +###################################################################### +sub nic_dslreports1_examples { + return <<"EoEXAMPLE"; +o 'dslreports1' + +The 'dslreports1' protocol is used by a free DSL monitoring service +offered by www.dslreports.com. + +Configuration variables applicable to the 'dslreports1' protocol are: + protocol=dslreports1 ## + server=fqdn.of.service ## defaults to www.dslreports.com + login=service-login ## login name and password registered with the service + password=service-password ## + unique-number ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=dslreports1, \\ + login=my-dslreports-login, \\ + password=my-dslreports-password \\ + 123456 + +Note: DSL Reports uses a unique number as the host name. This number +can be found on the Monitor Control web page. +EoEXAMPLE +} +###################################################################### +## nic_dslreports1_update +###################################################################### +sub nic_dslreports1_update { + debug("\nnic_dslreports1_update -------------------"); + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + my $url; + $url = "https://$config{$h}{'server'}/nic/"; + $url .= ynu($config{$h}{'static'}, 'statdns', 'dyndns', 'dyndns'); + $url .= "?action=edit&started=1&hostname=YES&host_id=$h"; + $url .= "&myip="; + $url .= $ip if $ip; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + + my @reply = split /\n/, $reply; + my $return_code = ''; + foreach my $line (@reply) { + $return_code = $1 if $line =~ m%^return\s+code\s*:\s*(.*)\s*$%i; + } + + if ($return_code !~ /NOERROR/) { + $config{$h}{'status'} = 'failed'; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s", $h); + + } else { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: %s: IP address set to %s", $h, $return_code, $ip); + } + } +} + +###################################################################### +## nic_zoneedit1_examples +###################################################################### +sub nic_zoneedit1_examples { + return <<"EoEXAMPLE"; +o 'zoneedit1' + +The 'zoneedit1' protocol is used by a DNS service offered by +www.zoneedit.com. + +Configuration variables applicable to the 'zoneedit1' protocol are: + protocol=zoneedit1 ## + server=fqdn.of.service ## defaults to www.zoneedit.com + zone=zone-where-domains-are ## only needed if 1 or more subdomains are deeper + ## than 1 level in relation to the zone where it + ## is defined. For example, b.foo.com in a zone + ## foo.com doesn't need this, but a.b.foo.com in + ## the same zone needs zone=foo.com + login=service-login ## login name and password registered with the service + password=service-password ## + your.domain.name ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=zoneedit1, \\ + server=dynamic.zoneedit.com, \\ + zone=zone-where-domains-are, \\ + login=my-zoneedit-login, \\ + password=my-zoneedit-password \\ + my.domain.name +EoEXAMPLE +} + +###################################################################### +## nic_zoneedit1_updateable +###################################################################### +sub nic_zoneedit1_updateable { + return 0; +} + +###################################################################### +## nic_zoneedit1_update +# +# +# +###################################################################### +sub nic_zoneedit1_update { + debug("\nnic_zoneedit1_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(login password server zone) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $h = $hosts[0]; + my $ip = $config{$h}{'wantip'}; + delete $config{$_}{'wantip'} foreach @hosts; + + info("setting IP address to %s for %s", $ip, $hosts); + verbose("UPDATE:", "updating %s", $hosts); + + my $url = ''; + $url .= "https://$config{$h}{'server'}/auth/dynamic.html"; + $url .= "?host=$hosts"; + $url .= "&dnsto=$ip" if $ip; + $url .= "&zone=$config{$h}{'zone'}" if defined $config{$h}{'zone'}; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); + next; + } + next if !header_ok($hosts, $reply); + + my @reply = split /\n/, $reply; + foreach my $line (@reply) { + if ($line =~ /^[^<]*<(SUCCESS|ERROR)\s+([^>]+)>(.*)/) { + my ($status, $assignments, $rest) = ($1, $2, $3); + my ($left, %var) = parse_assignments($assignments); + + if (keys %var) { + my ($status_code, $status_text, $status_ip) = ('999', '', $ip); + $status_code = $var{'CODE'} if exists $var{'CODE'}; + $status_text = $var{'TEXT'} if exists $var{'TEXT'}; + $status_ip = $var{'IP'} if exists $var{'IP'}; + + if ($status eq 'SUCCESS' || ($status eq 'ERROR' && $var{'CODE'} eq '707')) { + $config{$h}{'ip'} = $status_ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + + success("updating %s: IP address set to %s (%s: %s)", $h, $ip, $status_code, $status_text); + + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: %s: %s", $h, $status_code, $status_text); + } + shift @hosts; + $h = $hosts[0]; + $hosts = join(',', @hosts); + } + $line = $rest; + redo if $line; + } + } + failed("updating %s: no response from %s", $hosts, $config{$h}{'server'}) + if @hosts; + } +} +###################################################################### +## nic_easydns_updateable +###################################################################### +sub nic_easydns_updateable { + my $host = shift; + my $update = 0; + + if ($config{$host}{'mx'} ne $cache{$host}{'mx'}) { + info("forcing updating %s because 'mx' has changed to %s.", $host, $config{$host}{'mx'}); + $update = 1; + + } elsif ($config{$host}{'mx'} && (ynu($config{$host}{'backupmx'}, 1, 2, 3) ne ynu($config{$host}{'backupmx'}, 1, 2, 3))) { + info("forcing updating %s because 'backupmx' has changed to %s.", $host, ynu($config{$host}{'backupmx'}, "YES", "NO", "NO")); + $update = 1; + + } elsif ($config{$host}{'static'} ne $cache{$host}{'static'}) { + + info("forcing updating %s because 'static' has changed to %s.", $host, ynu($config{$host}{'static'}, "YES", "NO", "NO")); + $update = 1; + + } + return $update; +} +###################################################################### +## nic_easydns_examples +###################################################################### +sub nic_easydns_examples { + return <<"EoEXAMPLE"; +o 'easydns' + +The 'easydns' protocol is used by the for fee DNS service offered +by www.easydns.com. + +Configuration variables applicable to the 'easydns' protocol are: + protocol=easydns ## + server=fqdn.of.service ## defaults to members.easydns.com + backupmx=no|yes ## indicates that EasyDNS should be the secondary MX + ## for this domain or host. + mx=any.host.domain ## a host MX'ing for this host or domain. + wildcard=no|yes ## add a DNS wildcard CNAME record that points to {host} + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=easydns, \\ + login=my-easydns.com-login, \\ + password=my-easydns.com-password \\ + myhost.easydns.com + + ## multiple host update with wildcard'ing mx, and backupmx + protocol=easydns, \\ + login=my-easydns.com-login, \\ + password=my-easydns.com-password, \\ + mx=a.host.willing.to.mx.for.me, \\ + backupmx=yes, \\ + wildcard=yes \\ + my-toplevel-domain.com,my-other-domain.com + + ## multiple host update to the custom DNS service + protocol=easydns, \\ + login=my-easydns.com-login, \\ + password=my-easydns.com-password \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_easydns_update +###################################################################### +sub nic_easydns_update { + debug("\nnic_easydns_update -------------------"); + + ## each host is in a group by itself + my %groups = map { $_ => [ $_ ] } @_; + + my %errors = ( + 'NOACCESS' => 'Authentication failed. This happens if the username/password OR host or domain are wrong.', + 'NOSERVICE' => 'Dynamic DNS is not turned on for this domain.', + 'ILLEGAL' => 'Client sent data that is not allowed in a dynamic DNS update.', + 'TOOSOON' => 'Update frequency is too short.', + ); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $h = $hosts[0]; + my $ip = $config{$h}{'wantip'}; + delete $config{$_}{'wantip'} foreach @hosts; + + info("setting IP address to %s for %s", $ip, $hosts); + verbose("UPDATE:", "updating %s", $hosts); + + #'https://api.cp.easydns.com/dyn/generic.php?hostname=test.burry.ca&myip=10.20.30.40&wildcard=ON' + + my $url; + $url = "https://$config{$h}{'server'}$config{$h}{'script'}?"; + $url .= "hostname=$hosts"; + $url .= "&myip="; + $url .= $ip if $ip; + $url .= "&wildcard=" . ynu($config{$h}{'wildcard'}, 'ON', 'OFF', 'OFF') if defined $config{$h}{'wildcard'}; + + if ($config{$h}{'mx'}) { + $url .= "&mx=$config{$h}{'mx'}"; + $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); + } + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}); + next; + } + next if !header_ok($hosts, $reply); + + my @reply = split /\n/, $reply; + my $state = 'header'; + foreach my $line (@reply) { + if ($state eq 'header') { + $state = 'body'; + + } elsif ($state eq 'body') { + $state = 'results' if $line eq ''; + + } elsif ($state =~ /^results/) { + $state = 'results2'; + + my ($status) = $line =~ /^(\S*)\b.*/; + my $h = shift @hosts; + + $config{$h}{'status'} = $status; + if ($status eq 'NOERROR') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + success("updating %s: %s: IP address set to %s", $h, $status, $ip); + + } elsif ($status =~ /TOOSOON/) { + ## make sure we wait at least a little + my ($wait, $units) = (5, 'm'); + my ($sec, $scale) = ($wait, 1); + + ($scale, $units) = (1, 'seconds') if $units eq 's'; + ($scale, $units) = (60, 'minutes') if $units eq 'm'; + ($scale, $units) = (60*60, 'hours') if $units eq 'h'; + $config{$h}{'wtime'} = $now + $sec; + warning("updating %s: %s: wait %d %s before further updates", $h, $status, $wait, $units); + + } elsif (exists $errors{$status}) { + failed("updating %s: %s: %s", $h, $line, $errors{$status}); + + } else { + failed("updating %s: unexpected status (%s)", $h, $line); + } + last; + } + } + failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) + if $state ne 'results2'; + } +} +###################################################################### + +###################################################################### +## nic_namecheap_examples +###################################################################### +sub nic_namecheap_examples { + return <<"EoEXAMPLE"; + +o 'namecheap' + +The 'namecheap' protocol is used by DNS service offered by www.namecheap.com. + +Configuration variables applicable to the 'namecheap' protocol are: + protocol=namecheap ## + server=fqdn.of.service ## defaults to dynamicdns.park-your-domain.com + login=service-login ## the domain of the dynamic DNS record you want to update + password=service-password ## Generated password for your dynamic DNS record + hostname ## the subdomain to update, use @ for base domain name, * for catch all + +Example ${program}.conf file entries: + ## single host update + protocol=namecheap \\ + login=example.com \\ + password=example.com-generated-password \\ + @ + +EoEXAMPLE +} +###################################################################### +## nic_namecheap_update +## +## written by Dan Boardman +## +## based on https://www.namecheap.com/support/knowledgebase/ +## article.aspx/29/11/how-to-use-the-browser-to-dynamically-update-hosts-ip +## needs this url to update: +## https://dynamicdns.park-your-domain.com/update?host=host_name& +## domain=domain.com&password=domain_password[&ip=your_ip] +## +###################################################################### +sub nic_namecheap_update { + + + debug("\nnic_namecheap1_update -------------------"); + + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + my $url; + $url = "https://$config{$h}{'server'}/update"; + my $domain = $config{$h}{'login'}; + my $host = $h; + $host =~ s/(.*)\.$domain(.*)/$1$2/; + $url .= "?host=$host"; + $url .= "&domain=$domain"; + $url .= "&password=$config{$h}{'password'}"; + $url .= "&ip="; + $url .= $ip if $ip; + + my $reply = geturl(proxy => opt('proxy'), url => $url) // ''; + if ($reply eq '') { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + if (grep /0/i, @reply) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: Invalid reply.", $h); + } + } +} + +###################################################################### + +###################################################################### +## nic_nfsn_examples +###################################################################### +sub nic_nfsn_examples { + return <<"EoEXAMPLE"; + +o 'nfsn' + +The 'nfsn' protocol is used for the DNS service offered by www.nearlyfreespeech.net. Use this URL to get your API-Key-password: + https://members.nearlyfreespeech.net/support/assist?tag=apikey + +Configuration variables applicable to the 'nfsn' protocol are: + protocol=nfsn + server=api-server ## defaults to api.nearlyfreespeech.net + login=member-login ## NearlyFreeSpeech.net login name + password=api-key ## NearlyFreeSpeech.net API key + zone=zone ## The DNS zone under which the hostname falls; e.g. example.com + hostname ## the hostname to update in the specified zone; e.g. example.com or www.example.com + +Example ${program}.conf file entries: + ## update two hosts (example.com and www.example.com) in example.com zone + protocol=nfsn, \\ + login=my-nfsn-member-login, \\ + password=my-nfsn-api-key, \\ + zone=example.com \\ + example.com,www.example.com + + ## repeat the above for other zones, e.g. example.net: + [...] + zone=example.net \\ + subdomain1.example.net,subdomain2.example.net + +EoEXAMPLE +} + +###################################################################### +## nic_nfsn_gen_auth_header +###################################################################### +sub nic_nfsn_gen_auth_header { + my $h = shift; + my $path = shift; + my $body = shift // ''; + + ## API requests must include a custom HTTP header in the + ## following format: + ## + ## X-NFSN-Authentication: login;timestamp;salt;hash + ## + ## In this header, login is the member login name of the user + ## making the API request. + my $auth_header = 'X-NFSN-Authentication: '; + $auth_header .= $config{$h}{'login'} . ';'; + + ## timestamp is the standard 32-bit unsigned Unix timestamp + ## value. + my $timestamp = time(); + $auth_header .= $timestamp . ';'; + + ## salt is a randomly generated 16 character alphanumeric value + ## (a-z, A-Z, 0-9). + my @chars = ('A'..'Z', 'a'..'z', '0'..'9'); + my $salt; + for (my $i = 0; $i < 16; $i++) { + $salt .= $chars[int(rand(@chars))]; + } + $auth_header .= $salt . ';'; + + ## hash is a SHA1 hash of a string in the following format: + ## login;timestamp;salt;api-key;request-uri;body-hash + my $hash_string = $config{$h}{'login'} . ';' . + $timestamp . ';' . + $salt . ';' . + $config{$h}{'password'} . ';'; + + ## The request-uri value is the path portion of the requested URL + ## (i.e. excluding the protocol and hostname). + $hash_string .= $path . ';'; + + ## The body-hash is the SHA1 hash of the request body (if any). + ## If there is no request body, the SHA1 hash of the empty string + ## must be used. + my $body_hash = sha1_hex($body); + $hash_string .= $body_hash; + + my $hash = sha1_hex($hash_string); + $auth_header .= $hash; + $auth_header .= "\n"; + + return $auth_header; +} + +###################################################################### +## nic_nfsn_make_request +###################################################################### +sub nic_nfsn_make_request { + my $h = shift; + my $path = shift; + my $method = shift // 'GET'; + my $body = shift // ''; + + my $base_url = "https://$config{$h}{'server'}"; + my $url = $base_url . $path; + my $header = nic_nfsn_gen_auth_header($h, $path, $body); + if ($method eq 'POST' && $body ne '') { + $header .= "Content-Type: application/x-www-form-urlencoded\n"; + } + + return geturl( + proxy => opt('proxy'), + url => $url, + headers => $header, + method => $method, + data => $body, + ); +} + +###################################################################### +## nic_nfsn_handle_error +###################################################################### +sub nic_nfsn_handle_error { + my $resp = shift; + my $h = shift; + + $resp =~ s/^.*?\n\n//s; # Strip header + my $json = eval { decode_json($resp) }; + if ($@ || ref($json) ne 'HASH' || not defined $json->{'error'}) { + failed("Invalid error response: %s", $resp); + return; + } + + failed("%s", $json->{'error'}); + if (defined $json->{'debug'}) { + failed("%s", $json->{'debug'}); + } +} + +###################################################################### +## nic_nfsn_update +## +## Written by John Brooks +## +## Based on API docs: https://members.nearlyfreespeech.net/wiki/API/Introduction +## Uses the API endpoints under https://api.nearlyfreespeech.net/dns/$zone/ +## +## NB: There is no "updateRR" API function; to update an existing RR, we use +## removeRR to delete the RR, and then addRR to re-add it with the new data. +## +###################################################################### +sub nic_nfsn_update { + debug("\nnic_nfsn_update -------------------"); + + ## update each configured host + foreach my $h (@_) { + my $zone = $config{$h}{'zone'}; + my $name; + + if ($h eq $zone) { + $name = ''; + } elsif ($h !~ /$zone$/) { + $config{$h}{'status'} = 'failed'; + failed("updating %s: %s is outside zone %s", $h, $h, $zone); + next; + } else { + $name = $h; + $name =~ s/(.*)\.${zone}$/$1/; + } + + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE", "updating %s", $h); + + my $list_path = "/dns/$zone/listRRs"; + my $list_body = encode_www_form_urlencoded({name => $name, type => 'A'}); + my $list_resp = nic_nfsn_make_request($h, $list_path, 'POST', $list_body); + if (!header_ok($h, $list_resp)) { + $config{$h}{'status'} = 'failed'; + nic_nfsn_handle_error($list_resp, $h); + next; + } + + $list_resp =~ s/^.*?\n\n//s; # Strip header + my $list = eval { decode_json($list_resp) }; + if ($@) { + $config{$h}{'status'} = 'failed'; + failed("updating %s: JSON decoding failure", $h); + next; + } + + my $rr_ttl = $config{$h}{'ttl'}; + + if (ref($list) eq 'ARRAY' && defined $list->[0]->{'data'}) { + my $rr_data = $list->[0]->{'data'}; + my $rm_path = "/dns/$zone/removeRR"; + my $rm_data = {name => $name, + type => 'A', + data => $rr_data}; + my $rm_body = encode_www_form_urlencoded($rm_data); + my $rm_resp = nic_nfsn_make_request($h, $rm_path, + 'POST', $rm_body); + if (!header_ok($h, $rm_resp)) { + $config{$h}{'status'} = 'failed'; + nic_nfsn_handle_error($rm_resp); + next; + } + } + + my $add_path = "/dns/$zone/addRR"; + my $add_data = {name => $name, + type => 'A', + data => $ip, + ttl => $rr_ttl}; + my $add_body = encode_www_form_urlencoded($add_data); + my $add_resp = nic_nfsn_make_request($h, $add_path, 'POST', + $add_body); + if (header_ok($h, $add_resp)) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + nic_nfsn_handle_error($add_resp, $h); + } + } +} + +###################################################################### + +###################################################################### +## nic_njalla_examples +###################################################################### +sub nic_njalla_examples { + return <<"EoEXAMPLE"; + +o 'njalla' + +The 'njalla' protocol is used by DNS service offered by njal.la. + +Configuration variables applicable to the 'njalla' protocol are: + protocol=njalla ## + password=service-password ## Generated password for your dynamic DNS record + quietreply=no|yes ## If yes return empty response on success with status 200 but print errors + domain ## subdomain to update, use @ for base domain name, * for catch all + +Example ${program}.conf file entries: + ## single host update + protocol=njalla \\ + password=njal.la-key + quietreply=no + domain.com + +EoEXAMPLE +} +###################################################################### +## nic_njalla_update +## +## written by satrapes +## +## based on https://njal.la/docs/ddns/ +## needs this url to update: +## https://njal.la/update?h=host_name&k=domain_password&a=your_ip +## response contains "code 200" on succesful completion +###################################################################### +sub nic_njalla_update { + debug("\nnic_njalla_update -------------------"); + + foreach my $h (@_) { + # Read input params + my $ipv4 = delete $config{$h}{'wantipv4'}; + my $ipv6 = delete $config{$h}{'wantipv6'}; + my $quietreply = delete $config{$h}{'quietreply'}; + my $ip_output = ''; + + # Build url + my $url = "https://$config{$h}{'server'}/update/?h=$h&k=$config{$h}{'password'}"; + my $auto = 1; + foreach my $ip ($ipv4, $ipv6) { + next if (!$ip); + $auto = 0; + my $ipv = ($ip eq ($ipv6 // '')) ? '6' : '4'; + my $type = ($ip eq ($ipv6 // '')) ? 'aaaa' : 'a'; + $ip_output .= " IP v$ipv: $ip,"; + $url .= "&$type=$ip"; + } + $url .= (($auto eq 1)) ? '&auto' : ''; + $url .= (($quietreply eq 1)) ? '&quiet' : ''; + + info("setting address to%s for %s", ($ip_output eq '') ? ' auto' : $ip_output, $h); + verbose("UPDATE:", "updating %s", $h); + debug("url: %s", $url); + + # Try to get URL + my $reply = geturl(proxy => opt('proxy'), url => $url); + my $response = ''; + if ($quietreply) { + $reply =~ qr/invalid host or key/mp; + $response = ${^MATCH}; + if (!$response) { + success("updating %s: good: IP address set to %s", $h, $ip_output); + } + elsif ($response =~ /invalid host or key/) { + failed("Invalid host or key"); + } else { + failed("Unknown response"); + } + } else { + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + $response = eval {decode_json(${^MATCH})}; + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + } else { + # Strip header + if ($response->{status} == 401 && $response->{message} =~ /invalid host or key/) { + failed("Invalid host or key"); + } elsif ($response->{status} == 200 && $response->{message} =~ /record updated/) { + success("updating %s: good: IP address set to %s", $h, $response->{value}->{A}); + } else { + failed("Unknown response"); + } + } + } + } +} + +###################################################################### +## nic_sitelutions_examples +###################################################################### +sub nic_sitelutions_examples { + return <<"EoEXAMPLE"; + +o 'sitelutions' + +The 'sitelutions' protocol is used by DNS services offered by www.sitelutions.com. + +Configuration variables applicable to the 'sitelutions' protocol are: + protocol=sitelutions ## + server=fqdn.of.service ## defaults to sitelutions.com + login=service-login ## login name and password registered with the service + password=service-password ## + A_record_id ## Id of the A record for the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=sitelutions, \\ + login=my-sitelutions.com-login, \\ + password=my-sitelutions.com-password \\ + my-sitelutions.com-id_of_A_record + +EoEXAMPLE +} +###################################################################### +## nic_sitelutions_update +## +## written by Mike W. Smith +## +## based on https://www.sitelutions.com/help/dynamic_dns_clients#updatespec +## needs this url to update: +## https://www.sitelutions.com/dnsup?id=990331&user=myemail@mydomain.com&pass=SecretPass&ip=192.168.10.4 +## domain=domain.com&password=domain_password&ip=your_ip +## +###################################################################### +sub nic_sitelutions_update { + + + debug("\nnic_sitelutions_update -------------------"); + + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + my $url; + $url = "https://$config{$h}{'server'}/dnsup"; + $url .= "?id=$h"; + $url .= "&user=$config{$h}{'login'}"; + $url .= "&pass=$config{$h}{'password'}"; + $url .= "&ip="; + $url .= $ip if $ip; + + my $reply = geturl(proxy => opt('proxy'), url => $url); + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + if (grep /success/i, @reply) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: Invalid reply.", $h); + } + } +} + +###################################################################### + +###################################################################### +## nic_freedns_examples +###################################################################### +sub nic_freedns_examples { + return <<"EoEXAMPLE"; + +o 'freedns' + +The 'freedns' protocol is used by DNS services offered by freedns.afraid.org. + +Configuration variables applicable to the 'freedns' protocol are: + protocol=freedns ## + server=fqdn.of.service ## defaults to freedns.afraid.org + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=freedns, \\ + login=my-freedns.afraid.org-login, \\ + password=my-freedns.afraid.org-password \\ + myhost.afraid.com + +EoEXAMPLE +} +###################################################################### +## nic_freedns_update +## +## API v1 documented at https://freedns.afraid.org/api/ +## +## An update requires two steps. The first is to get a list of records from: +## https://freedns.afraid.org/api/?action=getdyndns&v=2&sha= +## The returned list looks like: +## +## hostname1.example.com|1.2.3.4|http://example/update/url1 +## hostname1.example.com|dead::beef|http://example/update/url2 +## hostname2.example.com|5.6.7.8|http://example/update/url3 +## hostname2.example.com|9.10.11.12|http://example/update/url4 +## hostname3.example.com|cafe::f00d|http://example/update/url5 +## hostname4.example.com|NULL|http://example/update/url6 +## +## The record's columns are separated by '|'. The first is the hostname, the second is the current +## address, and the third is the record-specific update URL. There can be multiple records for the +## same host, and they can even have the same address type. To update an IP address the record +## must already exist of the type we want to update... We will not change a record type from +## an IPv4 to IPv6 or viz versa. Records may exist with a NULL address which we will allow to be +## updated with an IPv4 address, not an IPv6. +## +## The second step is to visit the appropriate record's update URL with +## ?address= appended. "Updated" in the result means success, "fail" means +## failure. +###################################################################### +sub nic_freedns_update { + debug("\nnic_freedns_update -------------------"); + # Separate the records that are currently holding IPv4 addresses from the records that are + # currently holding IPv6 addresses so that we can avoid switching a record to a different + # address type. + my %recs_ipv4; + my %recs_ipv6; + my $url_tmpl = "https://$config{$_[0]}{'server'}/api/?action=getdyndns&v=2&sha="; + my $creds = sha1_hex("$config{$_[0]}{'login'}|$config{$_[0]}{'password'}"); + (my $url = $url_tmpl) =~ s//$creds/; + + my $reply = geturl(proxy => opt('proxy'), + url => $url + ); + my $record_list_error = ''; + if ($reply && header_ok($_[0], $reply)) { + $reply =~ s/^.*?\n\n//s; # Strip the headers. + for (split("\n", $reply)) { + my @rec = split(/\|/); + next if ($#rec < 2); + my $recs = is_ipv6($rec[1]) ? \%recs_ipv6 : \%recs_ipv4; + $recs->{$rec[0]} = \@rec; + # Update URL contains credentials that don't require login to use, so best to hide. + debug("host: %s, current address: %s, update URL: ", $rec[0], $rec[1]); + } + if (keys(%recs_ipv4) + keys(%recs_ipv6) == 0) { + chomp($reply); + $record_list_error = "failed to get record list from $url_tmpl: $reply"; + } + } else { + $record_list_error = "failed to get record list from $url_tmpl"; + } + + foreach my $h (@_) { + next if (!$h); + my $ipv4 = delete $config{$h}{'wantipv4'}; + my $ipv6 = delete $config{$h}{'wantipv6'}; + + if ($record_list_error ne '') { + $config{$h}{'status-ipv4'} = 'failed' if ($ipv4); + $config{$h}{'status-ipv6'} = 'failed' if ($ipv6); + failed("updating %s: %s", $h, $record_list_error); + next; + } + + # IPv4 and IPv6 handling are similar enough to do in a loop... + foreach my $ip ($ipv4, $ipv6) { + next if (!$ip); + my $ipv = ($ip eq ($ipv6 // '')) ? '6' : '4'; + my $type = ($ip eq ($ipv6 // '')) ? 'AAAA' : 'A'; + my $rec = ($ip eq ($ipv6 // '')) ? $recs_ipv6{$h} + : $recs_ipv4{$h}; + if (!$rec) { + failed("updating %s: Cannot set IPv$ipv to %s No '$type' record at FreeDNS", $h, $ip); + next; + } + + info("updating %s: setting IP address to %s", $h, $ip); + $config{$h}{"status-ipv$ipv"} = 'failed'; + + if ($ip eq $rec->[1]) { + $config{$h}{"ipv$ipv"} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{"status-ipv$ipv"} = 'good'; + success("updating %s: update not necessary, '$type' record already set to %s", $h, $ip) + if (!$daemon || opt('verbose')); + } else { + my $url = $rec->[2] . "&address=" . $ip; + ($url_tmpl = $url) =~ s/\?.*\&/?&/; # redact unique update token + debug("updating: %s", $url_tmpl); + + my $reply = geturl(proxy => opt('proxy'), + url => $url + ); + if ($reply && header_ok($h, $reply)) { + $reply =~ s/^.*?\n\n//s; # Strip the headers. + if ($reply =~ /Updated.*$h.*to.*$ip/) { + $config{$h}{"ipv$ipv"} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{"status-ipv$ipv"} = 'good'; + success("updating %s: good: IPv$ipv address set to %s", $h, $ip); + } else { + warning("SENT: %s", $url_tmpl) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: Invalid reply.", $h); + } + } else { + failed("updating %s: Could not connect to %s.", $h, $url_tmpl); + } + } + } + } +} + +###################################################################### +## nic_1984_examples +###################################################################### +sub nic_1984_examples { + return <<"EoEXAMPLE"; + +o '1984' + +The '1984' protocol is used by DNS services offered by 1984.is. + +Configuration variables applicable to the '1984' protocol are: + protocol=1984 ## + password=api-key ## your API key + fully.qualified.host ## the domain to update + +Example ${program}.conf file entries: + ## single host update + protocol=1984, \\ + password=my-1984-api-key, \\ + myhost + +EoEXAMPLE +} + +###################################################################### +## nic_1984_update +## https://api.1984.is/1.0/freedns/?apikey=xxx&domain=mydomain&ip=myip +## The response is a JSON document containing the following entries +## - ok: true or false depending on if the request was successful or not, +## if the ip is the same as before this will be true, +## - msg: successes or why it is not working, +## - lookup: if domain or subdomain was not found lookup will contain a list of names tried +###################################################################### +sub nic_1984_update { + debug("\nnic_1984_update -------------------"); + foreach my $host (@_) { + my $ip = delete $config{$host}{'wantip'}; + info("setting IP address to %s for %s", $ip, $host); + verbose("UPDATE:", "updating %s", $host); + + my $url; + $url = "https://$config{$host}{'server'}/1.0/freedns/"; + $url .= "?apikey=$config{$host}{'password'}"; + $url .= "&domain=$host"; + $url .= "&ip=$ip"; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + ) // ''; + if ($reply eq '') { + failed("Updating %s: Could not connect to %s.", $host, $config{$host}{'server'}); + next; + } + next if !header_ok($host, $reply); + + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + my $response = eval { decode_json(${^MATCH}) }; + if ($@) { + failed("Updating %s: JSON decoding failure", $host); + next; + } + unless ($response->{ok}) { + failed("%s", $response->{msg}); + } + + if ($response->{msg} =~ /unaltered/) { + success("Updating %s: skipped: IP was already set to %s", $host, $response->{ip}); + } else { + success("%s -- Updated successfully to %s", $host, $response->{ip}); + } + } +} + +###################################################################### +## nic_changeip_examples +###################################################################### +sub nic_changeip_examples { + return <<"EoEXAMPLE"; + +o 'changeip' + +The 'changeip' protocol is used by DNS services offered by changeip.com. + +Configuration variables applicable to the 'changeip' protocol are: + protocol=changeip ## + server=fqdn.of.service ## defaults to nic.changeip.com + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=changeip, \\ + login=my-my-changeip.com-login, \\ + password=my-changeip.com-password \\ + myhost.changeip.org + +EoEXAMPLE +} + +###################################################################### +## nic_changeip_update +## +## adapted by Michele Giorato +## +## https://nic.ChangeIP.com/nic/update?hostname=host.example.org&myip=66.185.162.19 +## +###################################################################### +sub nic_changeip_update { + + + debug("\nnic_changeip_update -------------------"); + + ## update each configured host + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + my $url; + $url = "https://$config{$h}{'server'}/nic/update"; + $url .= "?hostname=$h"; + $url .= "&ip="; + $url .= $ip if $ip; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ); + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + if (grep /success/i, @reply) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + warning("SENT: %s", $url) unless opt('verbose'); + warning("REPLIED: %s", $reply); + failed("updating %s: Invalid reply.", $h); + } + } +} + +###################################################################### +## nic_googledomains_examples +## +## written by awalon +## +###################################################################### +sub nic_godaddy_examples { + return <<"EoEXAMPLE"; + +o 'godaddy' + +The 'godaddy' protocol is used by DNS service offered by https://www.godaddy.com/domains. + +Configuration variables applicable to the 'godaddy' protocol are: + protocol=godaddy ## + login=my-generated-token ## the token/key name provided by the API interface + password=my-generated-secret ## the secret provided by the API interface + zone=domain.tld ## the domain used for DNS update. + ttl=600 ## time to live of the record; + hostname.domain.tld ## hostname/subdomain + +Example ${program}.conf file entries: + ## single host update + protocol=godaddy \\ + login=my-generated-token \\ + password=my-generated-secret \\ + zone=example.com \\ + hostname.example.com + + ## multiple host update to the DNS service + protocol=godaddy \\ + login=my-generated-token \\ + password=my-generated-secret \\ + zone=example.com \\ + host1.example.com,host2.example.com +EoEXAMPLE +} +###################################################################### +## nic_godaddy_update +###################################################################### +sub nic_godaddy_update { + debug("\nnic_godaddy_update --------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(server login password zone) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + + # Update each set configured host. + for my $host (@hosts) { + my $ip = delete $config{$host}{'wantip'}; + my $zone = $config{$host}{'zone'}; + (my $hostname = $host) =~ s/\.\Q$zone\E$//; + + info("%s.%s -- Setting IP address to %s.", $hostname, $zone, $ip); + verbose("UPDATE:", "updating %s.%s", $hostname, $zone); + + my $ipversion = is_ipv6($ip) ? "6" : "4"; + my $rrset_type = $ipversion == "6" ? "AAAA" : "A"; + my $data = encode_json([{ + data => $ip, + defined($config{$host}{'ttl'}) ? (ttl => $config{$host}{'ttl'}) : (), + name => $hostname, + type => $rrset_type, + }]); + + my $url = "https://$config{$host}{'server'}"; + $url .= "/${zone}/records/${rrset_type}/${hostname}"; + + my $header = "Content-Type: application/json\n"; + $header .= "Accept: application/json\n"; + $header .= "Authorization: sso-key $config{$host}{'login'}:$config{$host}{'password'}\n"; + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + headers => $header, + method => 'PUT', + data => $data, + ); + unless ($reply) { + failed("%s.%s -- Could not connect to %s.", $hostname, $zone, $config{$host}{'server'}); + next; + } + + (my $status) = ($reply =~ m%^s*HTTP/.*\s+(\d+)%i); + my $ok = header_ok($host, $reply); + my $msg; + $reply =~ s/^.*?\n\n//s; # extract payload + my $response = eval { decode_json($reply) }; + if (!defined($response) && $status != "200") { + $config{$host}{'status'} = "bad"; + + failed("%s.%s -- Unexpected or empty service response, cannot parse data.", $hostname, $zone); + } elsif (defined($response->{code})) { + verbose("%s.%s -- %s - %s.", $hostname, $zone, $response->{code}, $response->{message}); + } + if ($ok) { + # read data + $config{$host}{'ip'} = $ip; + $config{$host}{'mtime'} = $now; + $config{$host}{'status'} = "good"; + + success("%s.%s -- Updated successfully to %s (status: %s).", $hostname, $zone, $ip, $status); + next; + } elsif ($status == "400") { + $msg = 'GoDaddy API URL ($url) was malformed.'; + } elsif ($status == "401") { # authentication error + if ($config{$host}{'login'} && $config{$host}{'login'}) { + $msg = 'login or password option incorrect.'; + } else { + $msg = 'login or password option missing.'; + } + $msg .= ' Correct values can be obtained from from https://developer.godaddy.com/keys/.'; + } elsif ($status == "403") { + $msg = 'Customer identified by login and password options denied permission.'; + } elsif ($status == "404") { + $msg = "\"${hostname}.${zone}\" not found at GoDaddy, please check zone option and login/password."; + } elsif ($status == "422") { + $msg = "\"${hostname}.${zone}\" has invalid domain or lacks A/AAAA record."; + } elsif ($status == "429") { + $msg = 'Too many requests to GoDaddy within brief period.'; + } elsif ($status == "503") { + $msg = "\"${hostname}.${zone}\" is unavailable."; + } else { + $msg = 'Unexpected service response.'; + } + + $config{$host}{'status'} = "bad"; + failed("%s.%s -- %s", $hostname, $zone, $msg); + } + } +} + +###################################################################### +## nic_googledomains_examples +## +## written by Nelson Araujo +## +###################################################################### +sub nic_googledomains_examples { + return <<"EoEXAMPLE"; +o 'googledomains' + +The 'googledomains' protocol is used by DNS service offered by www.google.com/domains. + +Configuration variables applicable to the 'googledomains' protocol are: + protocol=googledomains ## + login=service-login ## the user name provided by the admin interface + password=service-password ## the password provided by the admin interface + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=googledomains, \\ + login=my-generated-user-name, \\ + password=my-genereated-password \\ + myhost.com + + ## multiple host update to the custom DNS service + protocol=googledomains, \\ + login=my-generated-user-name, \\ + password=my-genereated-password \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_googledomains_update +###################################################################### +sub nic_googledomains_update { + debug("\nnic_googledomains_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(server login password) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $key = $hosts[0]; + my $ip = $config{$key}{'wantip'}; + + # FQDNs + for my $host (@hosts) { + delete $config{$host}{'wantip'}; + + info("setting IP address to %s for %s", $ip, $host); + verbose("UPDATE:", "updating %s", $host); + + # Update the DNS record + my $url = "https://$config{$host}{'server'}/nic/update"; + $url .= "?hostname=$host"; + $url .= "&myip="; + $url .= $ip if $ip; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$host}{'login'}, + password => $config{$host}{'password'}, + ); + unless ($reply) { + failed("updating %s: Could not connect to %s.", $host, $config{$host}{'server'}); + next; + } + next if !header_ok($host, $reply); + + # Cache + $config{$host}{'ip'} = $ip; + $config{$host}{'mtime'} = $now; + $config{$host}{'status'} = 'good'; + } + } +} + +###################################################################### +## nic_nsupdate_examples +###################################################################### +sub nic_nsupdate_examples { + return <<"EoEXAMPLE"; +o 'nsupdate' + +The 'nsupdate' protocol is used to submit Dynamic DNS Update requests as +defined in RFC2136 to a name server using the 'nsupdate' command line +utility part of ISC BIND. Dynamic DNS updates allow resource records to +be added or removed from a zone configured for dynamic updates through +DNS requests protected using TSIG. BIND ships with 'ddns-confgen', a +utility to generate sample configurations and instructions for both the +server and the client. See nsupdate(1) and ddns-confgen(8) for details. + +Configuration variables applicable to the 'nsupdate' protocol are: + protocol=nsupdate + server=ns1.example.com ## name or IP address of the DNS server to send + ## the update requests to; usually master for + ## zone, but slaves should forward the request + password=tsig.key ## path and name of the symmetric HMAC key file + ## to use for TSIG signing of the request + ## (as generated by 'ddns-confgen -q' and + ## configured on server in 'grant' statement) + zone=dyn.example.com ## forward zone that is to be updated + ttl=600 ## time to live of the record; + ## defaults to 600 seconds + tcp=off|on ## nsupdate uses UDP by default, and switches to + ## TCP if the update is too large to fit in a + ## UDP datagram; this setting forces TCP; + ## defaults to off + login=/usr/bin/nsupdate ## path and name of nsupdate binary; + ## defaults to '/usr/bin/nsupdate' + ## fully qualified hostname to update + +Example ${program}.conf file entries: + ## single host update + protocol=nsupdate \\ + server=ns1.example.com \\ + password=/etc/${program}/dyn.example.com.key \\ + zone=dyn.example.com \\ + ttl=3600 \\ + myhost.dyn.example.com + +EoEXAMPLE +} + +###################################################################### +## nic_nsupdate_update +## by Daniel Roethlisberger +###################################################################### +sub nic_nsupdate_update { + debug("\nnic_nsupdate_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(login password server zone) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $h = $hosts[0]; + my $binary = $config{$h}{'login'}; + my $keyfile = $config{$h}{'password'}; + my $server = $config{$h}{'server'}; + ## nsupdate requires a port number to be separated by whitepace, not colon + $server =~ s/:/ /; + my $zone = $config{$h}{'zone'}; + my $ip = $config{$h}{'wantip'}; + my $recordtype = ''; + if (is_ipv6($ip)) { + $recordtype = 'AAAA'; + } else { + $recordtype = 'A'; + } + delete $config{$_}{'wantip'} foreach @hosts; + + info("setting IP address to %s for %s", $ip, $hosts); + verbose("UPDATE:", "updating %s", $hosts); + + ## send separate requests for each zone with all hosts in that zone + my $instructions = <<"EoINSTR1"; +server $server +zone $zone. +EoINSTR1 + foreach (@hosts) { + $instructions .= <<"EoINSTR2"; +update delete $_. $recordtype +update add $_. $config{$_}{'ttl'} $recordtype $ip +EoINSTR2 + } + $instructions .= <<"EoINSTR3"; +send +EoINSTR3 + my $command = "$binary -k $keyfile"; + $command .= " -v" if ynu($config{$h}{'tcp'}, 1, 0, 0); + $command .= " -d" if (opt('debug')); + verbose("UPDATE:", "nsupdate command is: %s", $command); + verbose("UPDATE:", "nsupdate instructions are:\n%s", $instructions); + + my $status = pipecmd($command, $instructions); + if ($status eq 1) { + foreach (@hosts) { + $config{$_}{'ip'} = $ip; + $config{$_}{'mtime'} = $now; + success("updating %s: %s: IP address set to %s", $_, $status, $ip); + } + } else { + foreach (@hosts) { + failed("updating %s", $_); + } + } + } +} + +###################################################################### + +###################################################################### +## nic_cloudflare_examples +## +## written by Ian Pye +## +###################################################################### +sub nic_cloudflare_examples { + return <<"EoEXAMPLE"; +o 'cloudflare' + +The 'cloudflare' protocol is used by DNS service offered by www.cloudflare.com. + +Configuration variables applicable to the 'cloudflare' protocol are: + protocol=cloudflare ## + server=fqdn.of.service ## defaults to api.cloudflare.com/client/v4 + login=service-login ## login email when using a global API key + password=service-password ## Global API key, or an API token. If using an API token, it must have the permissions "Zone - DNS - Edit" and "Zone - Zone - Read". The Zone resources must be "Include - All zones". + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update using a global API key + protocol=cloudflare, \\ + zone=dns.zone, \\ + login=my-cloudflare.com-login, \\ + password=my-cloudflare-global-key \\ + myhost.com + + ## single host update using an API token + protocol=cloudflare, \\ + zone=dns.zone, \\ + login=token, \\ + password=cloudflare-api-token \\ + myhost.com + + ## multiple host update to the custom DNS service + protocol=cloudflare, \\ + zone=dns.zone, \\ + login=my-cloudflare.com-login, \\ + password=my-cloudflare-global-api-key \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_cloudflare_update +###################################################################### +sub nic_cloudflare_update { + debug("\nnic_cloudflare_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(ssh login password server wildcard mx backupmx zone) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $key = $hosts[0]; + + my $headers = "Content-Type: application/json\n"; + if ($config{$key}{'login'} eq 'token') { + $headers .= "Authorization: Bearer $config{$key}{'password'}\n"; + } else { + $headers .= "X-Auth-Email: $config{$key}{'login'}\n"; + $headers .= "X-Auth-Key: $config{$key}{'password'}\n"; + } + + # FQDNs + for my $domain (@hosts) { + my $ipv4 = delete $config{$domain}{'wantipv4'}; + my $ipv6 = delete $config{$domain}{'wantipv6'}; + + info("getting Cloudflare Zone ID for %s", $domain); + + # Get zone ID + my $url = "https://$config{$key}{'server'}/zones/?"; + $url .= "name=" . $config{$key}{'zone'}; + + my $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$key}{'server'}); + next; + } + + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + my $response = eval {decode_json(${^MATCH})}; + unless ($response && $response->{result}) { + failed("updating %s: invalid json or result.", $domain); + next; + } + + # Pull the ID out of the json, messy + my ($zone_id) = map {$_->{name} eq $config{$key}{'zone'} ? $_->{id} : ()} @{$response->{result}}; + unless ($zone_id) { + failed("updating %s: No zone ID found.", $config{$key}{'zone'}); + next; + } + info("Zone ID is %s", $zone_id); + + + # IPv4 and IPv6 handling are similar enough to do in a loop... + foreach my $ip ($ipv4, $ipv6) { + next if (!$ip); + my $ipv = ($ip eq ($ipv6 // '')) ? '6' : '4'; + my $type = ($ip eq ($ipv6 // '')) ? 'AAAA' : 'A'; + + info("updating %s: setting IPv$ipv address to %s", $domain, $ip); + $config{$domain}{"status-ipv$ipv"} = 'failed'; + + # Get DNS 'A' or 'AAAA' record ID + $url = "https://$config{$key}{'server'}/zones/$zone_id/dns_records?"; + $url .= "type=$type&name=$domain"; + $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$key}{'server'}); + next; + } + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + $response = eval {decode_json(${^MATCH})}; + unless ($response && $response->{result}) { + failed("updating %s: invalid json or result.", $domain); + next; + } + # Pull the ID out of the json, messy + my ($dns_rec_id) = map {$_->{name} eq $domain ? $_->{id} : ()} @{$response->{result}}; + unless($dns_rec_id) { + failed("updating %s: Cannot set IPv$ipv to %s No '$type' record at Cloudflare", $domain, $ip); + next; + } + debug("updating %s: DNS '$type' record ID: $dns_rec_id", $domain); + # Set domain + $url = "https://$config{$key}{'server'}/zones/$zone_id/dns_records/$dns_rec_id"; + my $data = "{\"content\":\"$ip\"}"; + $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers, + method => "PATCH", + data => $data + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$domain}{'server'}); + next; + } + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + $response = eval {decode_json(${^MATCH})}; + if ($response && $response->{result}) { + success("updating %s: IPv$ipv address set to %s", $domain, $ip); + $config{$domain}{"ipv$ipv"} = $ip; + $config{$domain}{'mtime'} = $now; + $config{$domain}{"status-ipv$ipv"} = 'good'; + } else { + failed("updating %s: invalid json or result.", $domain); + } + } + } + } +} + +###################################################################### +## nic_hetzner_examples +## +## written by Joerg Werner +## +###################################################################### +sub nic_hetzner_examples { + return <<"EoEXAMPLE"; +o 'hetzner' + +The 'hetzner' protocol is used by DNS service offered by www.hetzner.com. + +Configuration variables applicable to the 'hetzner' protocol are: + protocol=hetzner ## + server=fqdn.of.service ## can be omitted, defaults to dns.hetzner.com/api/v1 + password=service-password ## API token + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + protocol=hetzner, \\ + zone=dns.zone, \\ + password=my-hetzner-api-token \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_hetzner_update +###################################################################### +sub nic_hetzner_update { + debug("\nnic_hetzner_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(ssh login password server wildcard mx backupmx zone) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $hosts = join(',', @hosts); + my $key = $hosts[0]; + + my $headers = "Auth-API-Token: $config{$key}{'password'}\n"; + $headers .= "Content-Type: application/json"; + + # FQDNs + for my $domain (@hosts) { + (my $hostname = $domain) =~ s/\.$config{$key}{zone}$//; + my $ipv4 = delete $config{$domain}{'wantipv4'}; + my $ipv6 = delete $config{$domain}{'wantipv6'}; + + info("getting Hetzner Zone ID for %s", $domain); + + # Get zone ID + my $url = "https://$config{$key}{'server'}/zones?name=" . $config{$key}{'zone'}; + + my $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$key}{'server'}); + next; + } + + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + my $response = eval {decode_json(${^MATCH})}; + unless ($response && $response->{zones}) { + failed("updating %s: invalid json or result.", $domain); + next; + } + + # Pull the ID out of the json, messy + my ($zone_id) = map {$_->{name} eq $config{$key}{'zone'} ? $_->{id} : ()} @{$response->{zones}}; + unless ($zone_id) { + failed("updating %s: No zone ID found.", $config{$key}{'zone'}); + next; + } + info("Zone ID is %s", $zone_id); + + + # IPv4 and IPv6 handling are similar enough to do in a loop... + foreach my $ip ($ipv4, $ipv6) { + next if (!$ip); + my $ipv = ($ip eq ($ipv6 // '')) ? '6' : '4'; + my $type = ($ip eq ($ipv6 // '')) ? 'AAAA' : 'A'; + + info("updating %s: setting IPv$ipv address to %s", $domain, $ip); + $config{$domain}{"status-ipv$ipv"} = 'failed'; + + # Get DNS 'A' or 'AAAA' record ID + $url = "https://$config{$key}{'server'}/records?$zone_id"; + $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$key}{'server'}); + next; + } + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + $response = eval {decode_json(${^MATCH})}; + unless ($response && $response->{records}) { + failed("updating %s: invalid json or result.", $domain); + next; + } + # Pull the ID out of the json, messy + my ($dns_rec_id) = map { ($_->{name} eq $hostname && $_->{type} eq $type) ? $_->{id} : ()} @{$response->{records}}; + + # Set domain + my $http_method=""; + if ($dns_rec_id) + { + debug("updating %s: DNS '$type' record ID: $dns_rec_id", $domain); + $url = "https://$config{$key}{'server'}/records/$dns_rec_id"; + $http_method = "PUT"; + } else { + debug("creating %s: DNS '$type'", $domain); + $url = "https://$config{$key}{'server'}/records"; + $http_method = "POST"; + } + my $data = "{\"zone_id\":\"$zone_id\", \"name\": \"$hostname\", \"value\": \"$ip\", \"type\": \"$type\", \"ttl\": $config{$domain}{'ttl'}}"; + + $reply = geturl(proxy => opt('proxy'), + url => $url, + headers => $headers, + method => $http_method, + data => $data + ); + unless ($reply && header_ok($domain, $reply)) { + failed("updating %s: Could not connect to %s.", $domain, $config{$domain}{'server'}); + next; + } + # Strip header + $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; + $response = eval {decode_json(${^MATCH})}; + if ($response && $response->{record}) { + success("updating %s: IPv$ipv address set to %s", $domain, $ip); + $config{$domain}{"ipv$ipv"} = $ip; + $config{$domain}{'mtime'} = $now; + $config{$domain}{"status-ipv$ipv"} = 'good'; + } else { + failed("updating %s: invalid json or result.", $domain); + } + } + } + } +} + +###################################################################### +## nic_yandex_examples +###################################################################### +sub nic_yandex_examples { + return <<"EoEXAMPLE"; +o Yandex + +The 'yandex' protocol is used to by DNS service offered by Yandex. + +Configuration variables applicable to the 'yandex' protocol are: + protocol=yandex ## + server=fqdn.of.service ## defaults to pddimp.yandex.ru + login=dns.zone ## Your zone name + password=pdd-token ## PDD token for authentication + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=yandex, \\ + login=myhost.com, \\ + password=123456789ABCDEF0000000000000000000000000000000000000 \\ + record.myhost.com + + ## multiple host update + protocol=yandex, \\ + login=myhost.com, \\ + password=123456789ABCDEF0000000000000000000000000000000000000 \\ + record.myhost.com,other.myhost.com +EoEXAMPLE +} +###################################################################### +## nic_yandex_update +## +## written by Denis Akimkin +## +###################################################################### +sub nic_yandex_update { + debug("\nnic_yandex_update -------------------"); + + ## group hosts with identical attributes together + my %groups = group_hosts_by([ @_ ], [ qw(server login pasword) ]); + + ## update each set of hosts that had similar configurations + foreach my $sig (keys %groups) { + my @hosts = @{$groups{$sig}}; + my $key = $hosts[0]; + my $ip = $config{$key}{'wantip'}; + my $headers = "PddToken: $config{$key}{'password'}\n"; + + # FQDNs + for my $host (@hosts) { + delete $config{$host}{'wantip'}; + + info("setting IP address to %s for %s", $ip, $host); + verbose("UPDATE:", "updating %s", $host); + + # Get record ID for host + my $url = "https://$config{$host}{'server'}/api2/admin/dns/list?"; + $url .= "domain="; + $url .= $config{$key}{'login'}; + my $reply = geturl(proxy => opt('proxy'), url => $url, headers => $headers); + unless ($reply) { + failed("updating %s: Could not connect to %s.", $host, $config{$key}{'server'}); + next; + } + next if !header_ok($host, $reply); + + # Strip header + $reply =~ s/^.*?\n\n//s; + my $response = eval { decode_json($reply) }; + if ($response->{success} eq 'error') { + failed("%s", $response->{error}); + next; + } + + # Pull the ID out of the json + my ($id) = map { $_->{fqdn} eq $host ? $_->{record_id} : () } @{$response->{records}}; + unless ($id) { + failed("updating %s: DNS record ID not found.", $host); + next; + } + + # Update the DNS record + $url = "https://$config{$host}{'server'}/api2/admin/dns/edit"; + my $data = "domain="; + $data .= $config{$key}{'login'}; + $data .= "&record_id="; + $data .= $id; + $data .= "&content="; + $data .= $ip if $ip; + + $reply = geturl( + proxy => opt('proxy'), + url => $url, + headers => $headers, + method => 'POST', + data => $data, + ); + unless ($reply) { + failed("updating %s: Could not connect to %s.", $host, $config{$host}{'server'}); + next; + } + next if !header_ok($host, $reply); + + # Strip header + $reply =~ s/^.*?\n\n//s; + $response = eval { decode_json($reply) }; + if ($response->{success} eq 'error') { + failed("%s", $response->{error}); + } else { + success("%s -- Updated Successfully to %s", $host, $ip); + } + + # Cache + $config{$host}{'ip'} = $ip; + $config{$host}{'mtime'} = $now; + $config{$host}{'status'} = 'good'; + } + } +} + +###################################################################### +## nic_duckdns_examples +###################################################################### +sub nic_duckdns_examples { + return <<"EoEXAMPLE"; +o 'duckdns' + +The 'duckdns' protocol is used by the free +dynamic DNS service offered by www.duckdns.org. +Check https://www.duckdns.org/install.jsp?tab=linux-cron for API + +Configuration variables applicable to the 'duckdns' protocol are: + protocol=duckdns ## + server=www.fqdn.of.service ## defaults to www.duckdns.org + password=service-password ## password (token) registered with the service + non-fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=duckdns, \\ + password=your_password, \\ + myhost + +EoEXAMPLE +} + +###################################################################### +## nic_duckdns_update +## by George Kranis (copypasta from nic_dtdns_update) +## https://www.duckdns.org/update?domains=mydomain1,mydomain2&token=xxxx-xxx-xx-x&ip=x.x.x.x +## response contains OK or KO +###################################################################### +sub nic_duckdns_update { + debug("\nnic_duckdns_update -------------------"); + + ## update each configured host + ## should improve to update in one pass + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + # Set the URL that we're going to to update + my $url; + $url = "https://$config{$h}{'server'}/update"; + $url .= "?domains="; + $url .= $h; + $url .= "&token="; + $url .= $config{$h}{'password'}; + $url .= "&ip="; + $url .= $ip; + + + # Try to get URL + my $reply = geturl(proxy => opt('proxy'), url => $url); + + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my $returned = pop(@reply); + if ($returned =~ /OK/) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: Server said: '%s'", $h, $returned); + } + } +} + +###################################################################### +## nic_freemyip_examples +###################################################################### +sub nic_freemyip_examples { + return <<"EoEXAMPLE"; +o 'freemyip' + +The 'freemyip' protocol is used by the free +dynamic DNS service available at freemyip.com. +API is documented here: https://freemyip.com/help.py + +Configuration variables applicable to the 'freemyip' protocol are: + protocol=freemyip ## + password=service-token ## token for your domain + non-fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=freemyip, \\ + password=35a6b8d65c6e67c7f78cca65cd \\ + myhost + +EoEXAMPLE +} + +###################################################################### +## nic_freemyip_update +## by Cadence (reused code from nic_duckdns) +## http://freemyip.com/update?token=ec54b4b64db27fe8873c7f7&domain=myhost +## response contains OK or ERROR +###################################################################### +sub nic_freemyip_update { + debug("\nnic_freemyip_update -------------------"); + + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + # Set the URL that we're going to to update + my $url; + $url = "https://$config{$h}{'server'}/update"; + $url .= "?token="; + $url .= $config{$h}{'password'}; + $url .= "&domain="; + $url .= $h; + + # Try to get URL + my $reply = geturl(proxy => opt('proxy'), url => $url); + + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my $returned = pop(@reply); + if ($returned =~ /OK/) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: Server said: '%s'", $h, $returned); + } + } +} + +###################################################################### +## nic_woima_examples +###################################################################### +sub nic_woima_examples { + return <<"EoEXAMPLE"; +o 'woima' + +The 'woima' protocol is used by the free +dynamic DNS service offered by woima.fi. +It offers also nameservers for own domains for free. +Dynamic DNS service for own domains is not free. + +Configuration variables applicable to the 'woima' protocol are: + protocol=woima ## + server=fqdn.of.service ## defaults to dyn.woima.fi + script=/path/to/script ## defaults to /nic/update + backupmx=no|yes ## indicates that this host is the primary MX for the domain. + static=no|yes ## indicates that this host has a static IP address. + custom=no|yes ## indicates that this host is a 'custom' top-level domain name. + mx=any.host.domain ## a host MX'ing for this host definition. + wildcard=no|yes ## add a DNS wildcard CNAME record that points to {host} + login=service-login ## login name and password registered with the service + password=service-password ## + fully.qualified.host ## the host registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=woima, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password \\ + myhost.dyndns.org + + ## multiple host update with wildcard'ing mx, and backupmx + protocol=woima, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password, \\ + mx=a.host.willing.to.mx.for.me,backupmx=yes,wildcard=yes \\ + myhost.dyndns.org,my2ndhost.dyndns.org + + ## multiple host update to the custom DNS service + protocol=woima, \\ + login=my-dyndns.org-login, \\ + password=my-dyndns.org-password \\ + my-toplevel-domain.com,my-other-domain.com +EoEXAMPLE +} +###################################################################### +## nic_woima_update +###################################################################### +sub nic_woima_update { + debug("\nnic_woima_update -------------------"); + + my %errors = ( + 'badauth' => 'Bad authorization (username or password)', + 'badsys' => 'The system parameter given was not valid', + + 'notfqdn' => 'A Fully-Qualified Domain Name was not provided', + 'nohost' => 'The hostname specified does not exist in the database', + '!yours' => 'The hostname specified exists, but not under the username currently being used', + '!donator' => 'The offline setting was set, when the user is not a donator', + '!active' => 'The hostname specified is in a Custom DNS domain which has not yet been activated.', + 'abuse', => 'The hostname specified is blocked for abuse; you should receive an email notification ' . + 'which provides an unblock request link. More info can be found on ' . + 'https://www.dyndns.com/support/abuse.html', + + 'numhost' => 'System error: Too many or too few hosts found. Contact support@dyndns.org', + 'dnserr' => 'System error: DNS error encountered. Contact support@dyndns.org', + + 'nochg' => 'No update required; unnecessary attempts to change to the current address are considered abusive', + ); + + for my $h (@_) { + my $ip = $config{$h}{'wantip'}; + delete $config{$h}{'wantip'}; + + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + ## Select the DynDNS system to update + ## TODO: endpoint does not support https with functioning certificate. Remove? + my $url = "http://$config{$h}{'server'}$config{$h}{'script'}?system="; + if ($config{$h}{'custom'}) { + warning("updating %s: 'custom' and 'static' may not be used together. ('static' ignored)", $h) + if $config{$h}{'static'}; + $url .= 'custom'; + + } elsif ($config{$h}{'static'}) { + $url .= 'statdns'; + + } else { + $url .= 'dyndns'; + } + + $url .= "&hostname=$h"; + $url .= "&myip="; + $url .= $ip if $ip; + + ## some args are not valid for a custom domain. + $url .= "&wildcard=ON" if ynu($config{$h}{'wildcard'}, 1, 0, 0); + if ($config{$h}{'mx'}) { + $url .= "&mx=$config{$h}{'mx'}"; + $url .= "&backmx=" . ynu($config{$h}{'backupmx'}, 'YES', 'NO'); + } + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ); + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my $state = 'header'; + my $returnedip = $ip; + + foreach my $line (@reply) { + if ($state eq 'header') { + $state = 'body'; + + } elsif ($state eq 'body') { + $state = 'results' if $line eq ''; + + } elsif ($state =~ /^results/) { + $state = 'results2'; + + # bug #10: some dyndns providers does not return the IP so + # we can't use the returned IP + my ($status, $returnedip) = split / /, lc $line; + $ip = $returnedip if (not $ip); + + $config{$h}{'status'} = $status; + if ($status eq 'good') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + success("updating %s: %s: IP address set to %s", $h, $status, $ip); + + } elsif (exists $errors{$status}) { + if ($status eq 'nochg') { + warning("updating %s: %s: %s", $h, $status, $errors{$status}); + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + + } else { + failed("updating %s: %s: %s", $h, $status, $errors{$status}); + } + + } elsif ($status =~ /w(\d+)(.)/) { + my ($wait, $units) = ($1, lc $2); + my ($sec, $scale) = ($wait, 1); + + ($scale, $units) = (1, 'seconds') if $units eq 's'; + ($scale, $units) = (60, 'minutes') if $units eq 'm'; + ($scale, $units) = (60*60, 'hours') if $units eq 'h'; + + $sec = $wait * $scale; + $config{$h}{'wtime'} = $now + $sec; + warning("updating %s: %s: wait %s %s before further updates", $h, $status, $wait, $units); + + } else { + failed("updating %s: unexpected status (%s)", $h, $line); + } + } + } + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}) + if $state ne 'results2'; + } +} + +###################################################################### +## nic_dondominio_examples +###################################################################### +sub nic_dondominio_examples { + return <<"EoEXAMPLE"; +o 'dondominio' +The 'dondominio' protocol is used by DNS service offered by www.dondominio.com/ . +API information and user instructions available at: https://dev.dondominio.com/dondns/docs/api/ +Configuration variables applicable to the 'dondominio' protocol are: + protocol=dondominio ## + login=service-login ## the username registered with the service + password=dondominio-apikey ## API key provided by dondominio -see link above- + fully.qualified.host ## the host registered with the service. +Example ${program}.conf file entries: + ## single host update + protocol=dondominio, \\ + login=my-generated-user-name, \\ + password=dondominio-apikey \\ + myhost.tld + +EoEXAMPLE +} + +###################################################################### +## nic_dondominio_examples +###################################################################### + +sub nic_dondominio_update { + debug("\nnic_dondominio_update -------------------"); + + ## update each configured host + ## should improve to update in one pass + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + + # Set the URL that we're going to update + my $url; + $url = "https://$config{$h}{'server'}/plain/"; + $url .= "?user="; + $url .= $config{$h}{'login'}; + $url .= "&password="; + $url .= $config{$h}{'password'}; + $url .= "&host="; + $url .= $h; + $url .= "&ip="; + $url .= $ip if $ip; + + + # Try to get URL + my $reply = geturl(proxy => opt('proxy'), url => $url); + + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my $returned = pop(@reply); + if ($returned =~ /OK/) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: Server said: '%s'", $h, $returned); + } + } +} + +###################################################################### +## nic_dnsmadeeasy_examples +###################################################################### +sub nic_dnsmadeeasy_examples { + return <<"EoEXAMPLE"; +o 'dnsmadeeasy' + +The 'dnsmadeeasy' protocol is used by the DNS Made Easy service at https://www.dnsmadeeasy.com. +API is documented here: https://dnsmadeeasy.com/technology/dynamic-dns/ + +Configuration variables applicable to the 'dnsmadeeasy' protocol are: + protocol=dnsmadeeasy ## + login=email-address ## Email address used to log in to your account. + password=dynamic-record-password ## Generated password for your dynamic DNS record. + record-id-1,record-id-2,... ## Numeric dynamic DNS record IDs, comma-separated if updating multiple. + +Note: Dynamic record ID is generated when you create a new Dynamic DNS record in the DNS Made Easy control panel. + +Example ${program}.conf file entries: + ## single host update + protocol=dnsmadeeasy, \\ + username=dme\@example.com, \\ + password=myg3nerat3dp4ssword, \\ + 1007,1008 + +EoEXAMPLE +} + +###################################################################### +## nic_dnsmadeeasy_update +###################################################################### +sub nic_dnsmadeeasy_update { + debug("\nnic_dnsmadeeasy_update -------------------"); + + my %messages = ( + 'error-auth' => 'Invalid username or password, or invalid IP syntax', + 'error-auth-suspend' => 'User has had their account suspended due to complaints or misuse of the service.', + 'error-auth-voided' => 'User has had their account permanently revoked.', + 'error-record-invalid' =>'Record ID number does not exist in the system.', + 'error-record-auth' => 'User does not have access to this record.', + 'error-record-ip-same' => 'No update required.', + 'error-system' => 'General system error which is caught and recognized by the system.', + 'error' => 'General system error unrecognized by the system.', + 'success' => 'Record successfully updated!', + ); + + ## update each configured host + ## should improve to update in one pass + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("Setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "Updating %s", $h); + + # Set the URL that we're going to to update + my $url; + $url = $globals{'ssl'} ? "https://" : "http://"; + $url .= $config{$h}{'server'} . $config{$h}{'script'}; + $url .= "?username=$config{$h}{'login'}"; + $url .= "&password=$config{$h}{'password'}"; + $url .= "&ip=$ip"; + $url .= "&id=$h"; + + # Try to get URL + my $reply = geturl(proxy => opt('proxy'), url => $url); + + # No response, declare as failed + if (!defined($reply) || !$reply) { + failed("Updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + next if !header_ok($h, $reply); + + my @reply = split /\n/, $reply; + my $returned = pop(@reply); + if ($returned =~ 'success') { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("Updating %s: good: IP address set to %s", $h, $ip); + } else { + $config{$h}{'status'} = 'failed'; + failed("Updating %s: Server said: '%s': %s", $h, $returned, $messages{$returned}); + } + } +} + +###################################################################### +## nic_ovh_examples +###################################################################### +sub nic_ovh_examples { + return <<"EoEXAMPLE"; + +o 'ovh' + +The 'ovh' protocol is used by DNS services offered by www.ovh.com. + +API information and user instructions available at: https://docs.ovh.com/gb/en/domains/hosting_dynhost/ + +Configuration variables applicable to the 'ovh' protocol are: + protocol=ovh ## + login=dnsdomain-userid ## The username/id registered with the service + password=userid-password ## The password related to the username/id + fully.qualified.host ## the hostiname registered with the service. + +Example ${program}.conf file entries: + ## single host update + protocol=ovh, \\ + login=example.com-dynhostuser, \\ + password=your_password, \\ + test.example.com + +EoEXAMPLE +} + +###################################################################### +## nic_ovh_update +###################################################################### +sub nic_ovh_update { + debug("\nnic_ovh_update -------------------"); + + ## update each configured host + ## should improve to update in one pass + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:","updating %s", $h); + + # Set the URL that we're going to update + my $url; + $url .= "https://$config{$h}{'server'}$config{$h}{'script'}?system=dyndns"; + $url .= "&hostname=$h"; + $url .= "&myip="; + $url .= $ip if $ip; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + ); + + if (!defined($reply) || !$reply) { + failed("updating %s: Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + + my @reply = split /\n/, $reply; + my $returned = pop(@reply); + if ($returned =~ /good/ || $returned =~ /nochg/) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + if ($returned =~ /good/) { + success("updating %s: good: IP address set to %s", $h, $ip); + } else { + success("updating %s: skipped: IP address was already set to %s.", $h, $ip); + } + } else { + $config{$h}{'status'} = 'failed'; + failed("updating %s: Server said: '%s'", $h, $returned); + } + } +} + +sub nic_cloudns_examples { + return <<"EoEXAMPLE"; +o 'cloudns' + +The 'cloudns' protocol is used for ClouDNS (https://www.cloudns.net). Details +about dynamic DNS updates can be found at https://www.cloudns.net/dynamic-dns/. + +Available configuration variables: + * dynurl: The DynURL associated with the A or AAAA record you wish to update. + +Limitations: + * $program cannot tell if the DynURL you provide belongs to the hostname you + specify. + * ClouDNS does not document how to tell whether an update suceeded or failed, + so there is no way for $program to reliably handle failures. + * The ClouDNS API does not provide a reliable way to set the desired IP + address. It might save the IP address you want, or it might save the IP + address that connects to CloudDNS. It is more likely to work if you do not + use a proxy. + +Example ${program}.conf file entry: + protocol=cloudns, \\ + dynurl=https://ipv4.cloudns.net/api/dynamicURL/?q=Njc1OTE2OjY3Njk0ND..., \\ + myhost.example.com +EoEXAMPLE +} + +sub nic_cloudns_update { + my %groups = group_hosts_by([ @_ ], [ qw(dynurl) ]); + for my $hr (values(%groups)) { + my @hosts = @$hr; + my $hosts = join(',', @hosts); + my $ip = $config{$hosts[0]}{'wantip'}; + my $dynurl = $config{$hosts[0]}{'dynurl'}; + delete $config{$_}{'wantip'} for @hosts; + # https://www.cloudns.net/wiki/article/36/ says, "If you are behind a proxy and your real + # IP is set in the header X-Forwarded-For you need to add &proxy=1 at the end of the + # DynamicURL." We abuse this to pass the desired IP address to ClouDNS, which might not be + # the same as the client IP address seen by ClouDNS. + my $reply = geturl( + proxy => opt('proxy'), + url => $dynurl . '&proxy=1', + headers => "X-Forwarded-For: $ip\n", + ); + if (($reply // '') eq '' || !header_ok($hosts, $reply)) { + $config{$_}{'status'} = 'failed' for @hosts; + failed("updating %s: failed to visit DynURL", $hosts); + next; + } + $reply =~ s/^.*?\n\n//s; # Strip the headers. + chomp($reply); + if ($reply eq "The record's key is wrong!" || $reply eq "Invalid request.") { + $config{$_}{'status'} = 'failed' for @hosts; + failed("updating %s: %s", $hosts, $reply); + next; + } + # There's no documentation explaining possible return values, so we assume success. + $config{$_}{'ip'} = $ip for @hosts; + $config{$_}{'mtime'} = $now for @hosts; + $config{$_}{'status'} = 'good' for @hosts; + success("updating %s: IP address set to %s", $hosts, $ip); + } +} + +###################################################################### +## nic_dinahosting_examples +###################################################################### +sub nic_dinahosting_examples { + return <<"EoEXAMPLE"; +o 'dinahosting' + +The 'dinahosting' protocol is used by dinahosting (https://dinahosting.com). +Details about the API can be found at https://dinahosting.com/api. + +Available configuration variables and their defaults: + * login (required) is your username. + * password (required) is your password. + * server=dinahosting.com is the hostname part of the dinahosting API URL. + * script=/special/api.php is the path part of the dinahosting API URL. + +Example ${program}.conf file entry: + protocol=dinahosting, \\ + login=myusername, \\ + password=mypassword \\ + myhost.mydomain.com +EoEXAMPLE +} + +###################################################################### +## nic_dinahosting_update +###################################################################### +sub nic_dinahosting_update { + debug("\nnic_dinahosting_update -------------------"); + for my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + info("setting IP address to %s for %s", $ip, $h); + verbose("UPDATE:", "updating %s", $h); + my ($hostname, $domain) = split(/\./, $h, 2); + my $url = "https://$config{$h}{'server'}$config{$h}{'script'}"; + $url .= "?hostname=$hostname"; + $url .= "&domain=$domain"; + $url .= "&command=Domain_Zone_UpdateType" . is_ipv6($ip) ? 'AAAA' : 'A'; + $url .= "&ip=$ip"; + my $reply = geturl( + proxy => opt('proxy'), + login => $config{$h}{'login'}, + password => $config{$h}{'password'}, + url => $url, + ); + $config{$h}{'status'} = 'failed'; # assume failure until otherwise determined + if (!$reply) { + failed("updating %s: failed to visit URL %s", $h, $url); + next; + } + next if !header_ok($h, $reply); + $reply =~ s/^.*?\n\n//s; # Strip the headers. + if ($reply !~ /Success/i) { + $reply =~ /^responseCode = (\d+)$/m; + my $code = $1 // ''; + $reply =~ /^errors_0_message = '(.*)'$/m; + my $message = $1 // ''; + failed("updating %s: error %d: %s", $code, $message); + next; + } + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = 'good'; + success("updating %s: IP address set to %s", $h, $ip); + } +} + +###################################################################### +## nic_gandi_examples +## by Jimmy Thrasibule +###################################################################### +sub nic_gandi_examples { + return <<"EoEXAMPLE"; +o 'gandi' + +The 'gandi' protocol is used by the LiveDNS service offered by gandi.net. +Description of Gandi's LiveDNS API can be found at: + + https://api.gandi.net/docs/livedns/ + +Available configuration variables: + * password: The Gandi API key. If you don’t have one yet, you can generate + your production API key from the API Key Page (in the Security section). + Required. + * zone: The DNS zone to be updated. Required. + * ttl: The time-to-live value associated with the updated DNS record. + Optional; uses Gandi's default (3h) if unset. + +Example ${program}.conf file entries: + ## Single host update. + protocol=gandi, \\ + zone=example.com, \\ + password=my-gandi-api-key, \\ + host.example.com + + ## Multiple host update. + protocol=gandi, \\ + zone=example.com, \\ + password=my-gandi-api-key, \\ + ttl=1h \\ + hosta.example.com,hostb.sub.example.com +EoEXAMPLE +} + +###################################################################### +## nic_gandi_update +###################################################################### +sub nic_gandi_update { + debug("\nnic_gandi_update -------------------"); + + # Update each set configured host. + foreach my $h (@_) { + my $ip = delete $config{$h}{'wantip'}; + (my $hostname = $h) =~ s/\.\Q$config{$h}{zone}\E$//; + + info("%s -- Setting IP address to %s.", $h, $ip); + verbose("UPDATE:", "updating %s", $h); + + my $headers; + $headers = "Content-Type: application/json\n"; + $headers .= "Authorization: Apikey $config{$h}{'password'}\n"; + + my $data = encode_json({ + defined($config{$h}{'ttl'}) ? (rrset_ttl => $config{$h}{'ttl'}) : (), + rrset_values => [$ip], + }); + + my $rrset_type = is_ipv6($ip) ? "AAAA" : "A"; + my $url; + $url = "https://$config{$h}{'server'}$config{$h}{'script'}"; + $url .= "/livedns/domains/$config{$h}{'zone'}/records/$hostname/$rrset_type"; + + my $reply = geturl( + proxy => opt('proxy'), + url => $url, + headers => $headers, + method => 'PUT', + data => $data, + ); + unless ($reply) { + failed("%s -- Could not connect to %s.", $h, $config{$h}{'server'}); + next; + } + my $ok = header_ok($h, $reply); + + $reply =~ s/^.*?\n\n//s; + my $response = eval { decode_json($reply) }; + if (!defined($response)) { + $config{$h}{'status'} = "bad"; + + failed("%s -- Unexpected service response.", $h); + next; + } + + if ($ok) { + $config{$h}{'ip'} = $ip; + $config{$h}{'mtime'} = $now; + $config{$h}{'status'} = "good"; + + success("%s -- Updated successfully to %s.", $h, $ip); + } else { + $config{$h}{'status'} = "bad"; + + if (defined($response->{status}) && $response->{status} eq "error") { + my @errors; + for my $err (@{$response->{errors}}) { + push(@errors, $err->{description}); + } + failed("%s -- %s.", $h, join(", ", @errors)); + } else { + failed("%s -- Unexpected service response.", $h); + } + } + } +} +###################################################################### +## nic_keysystems_examples +###################################################################### +sub nic_keysystems_examples { + return <main() unless caller() && caller() ne 'PAR'; + +###################################################################### +## Emacs and Vim settings + +# Local Variables: +# mode: perl +# fill-column: 99 +# indent-tabs-mode: nil +# perl-indent-level: 4 +# tab-width: 8 +# End: + +# vim: ai et ts=8 sw=4 tw=99 cc=+1 filetype=perl + +__END__ diff -Nru ddclient-3.9.1/debian/changelog ddclient-3.10.0/debian/changelog --- ddclient-3.9.1/debian/changelog 2022-10-15 09:59:04.000000000 +0000 +++ ddclient-3.10.0/debian/changelog 2023-01-16 02:47:24.000000000 +0000 @@ -1,3 +1,40 @@ +ddclient (3.10.0-2) unstable; urgency=medium + + * Fix SSL certificate verification with IPv6 address literals + (Closes: #1028849) + + -- Richard Hansen Sun, 15 Jan 2023 21:47:24 -0500 + +ddclient (3.10.0-1) unstable; urgency=medium + + [ Debian Janitor ] + * Remove constraints unnecessary since buster (oldstable): + + ddclient: Drop versioned constraint on lsb-base in Depends. + + [ Richard Hansen ] + * Fix Portuguese (Portugal) debconf translation + * Update lintian override to accommodate newer lintian versions + * Bump debhelper-compat to 13 (no changes needed) + * Bump Standards-Version to 4.6.1 (no changes needed) + * Update debian/copyright + * New upstream version 3.10.0 (Closes: #1021345) + + Refresh patches + + Update dependencies + + Accommodate upstream's new build system + + Update debian/copyright for third-party modules in t/lib + + debconf: Update protocols and built-in IP discovery services + + Fix version in configure.ac + + Fix flawed default interface IP address tests + * Remove extra quotes in sysvinit script (Closes: #998650) + * postinst: Update dh_installinit and dh_installsystemd generated code + (Closes: #1022810) + * Update Portuguese (Portugal) debconf translation. + Thanks to Américo Monteiro (Closes: #982327) + * Remove unnecessary dependency on lsb-base + * prerm: Update dh_installinit and dh_installsystemd generated code + + -- Richard Hansen Tue, 29 Nov 2022 13:30:24 -0500 + ddclient (3.9.1-7.1) unstable; urgency=medium * Non-maintainer upload. diff -Nru ddclient-3.9.1/debian/config ddclient-3.10.0/debian/config --- ddclient-3.9.1/debian/config 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/config 2023-01-16 02:47:24.000000000 +0000 @@ -182,9 +182,8 @@ db_get ddclient/web; web=${RET%% *} case ${web} in other) db_input critical ddclient/web-url || true;; - # Use ddclient's built-in shorthands when possible - dyndns|loopia) db_set ddclient/web-url "";; - *) db_set ddclient/web-url "${RET##* }";; + # Use ddclient's built-in shorthands. + *) db_set ddclient/web-url "";; esac ;; "Network interface") diff -Nru ddclient-3.9.1/debian/control ddclient-3.10.0/debian/control --- ddclient-3.9.1/debian/control 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/control 2023-01-16 02:47:24.000000000 +0000 @@ -2,8 +2,21 @@ Section: net Priority: optional Maintainer: Richard Hansen -Build-Depends: debhelper-compat (= 12), dh-exec, po-debconf, xmlto, quilt -Standards-Version: 4.5.0 +Build-Depends: debhelper-compat (= 13), dh-exec, po-debconf, xmlto, quilt +Build-Depends-Indep: + libhttp-daemon-perl (>= 6.12) , + libhttp-daemon-ssl-perl , + libhttp-message-perl , + libio-socket-inet6-perl , + libio-socket-ip-perl , + libio-socket-ssl-perl , + libplack-perl , + libtest-mockmodule-perl , + libtest-tcp-perl , + libtest-warnings-perl , + liburi-perl , + perl +Standards-Version: 4.6.1 Homepage: https://ddclient.net Vcs-Git: https://salsa.debian.org/debian/ddclient.git Vcs-Browser: https://salsa.debian.org/debian/ddclient @@ -11,9 +24,20 @@ Package: ddclient Architecture: all -Pre-Depends: ${misc:Pre-Depends} -Depends: ${perl:Depends}, libdata-validate-ip-perl, ${misc:Depends}, lsb-base (>= 3.1) -Recommends: libio-socket-ssl-perl, libio-socket-inet6-perl, libdigest-sha-perl, libjson-pp-perl +# init-system-helpers is normally included in ${misc:Pre-Depends}, but not when +# --no-enable --no-start is passed to dh_installinit. It is included here to +# silence a skip-systemd-native-flag-missing-pre-depends lintian warning. (It +# is unclear whether this dependency is actually required, as +# init-system-helpers is an essential package. dh_installinit uses a versioned +# requirement for the init-system-helpers dependency so the same is done here.) +Pre-Depends: ${misc:Pre-Depends}, init-system-helpers (>= 1.54~) +Depends: ${perl:Depends}, ${misc:Depends} +Recommends: + iproute2, + libio-socket-ssl-perl, + libio-socket-inet6-perl, + libdigest-sha-perl, + libjson-pp-perl, Provides: dyndns-client Description: address updating utility for dynamic DNS services This package provides a client to update dynamic IP addresses with diff -Nru ddclient-3.9.1/debian/copyright ddclient-3.10.0/debian/copyright --- ddclient-3.9.1/debian/copyright 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/copyright 2023-01-16 02:47:24.000000000 +0000 @@ -10,7 +10,8 @@ Files: debian/* Copyright: - 2005-2014 Torsten Landschoff + 2020-2023 Richard Hansen + 2005-2016 Torsten Landschoff 2014 Tong Sun 2013 Teemu Ikonen 2013 Antonio Terceiro @@ -24,6 +25,16 @@ Files: debian/po/* Copyright: + 2021 Américo Monteiro + 2020 Ari Ervasti + 2020 Jean-Pierre Giraud + 2020 Adriano Rafael Gomes + 2020 José Vieira + 2020 Sebastian Rasmussen + 2020 Rui Branco + 2020 Takuma Yamada + 2020 Richard Hansen + 2014, 2020 Frans Spiesschaert 2014 Miroslav Kure 2014 Kenshi Muto 2014 Olexandr Kravchuk @@ -41,7 +52,7 @@ 2009 marce villarino 2009 Esko Arajärvi 2009 Bjørn Steensrud - 2009, 2010 Yuri Kozlov + 2009, 2010, 2020 Yuri Kozlov 2009, 2010 Miguel Figueiredo 2009, 2010 Martin Bagge 2009, 2010 Ivan Masár @@ -52,7 +63,7 @@ 2007 Jacobo Tarrio 2006 Ricardo Silva 2006, 2009 Jordà Polo - 2006, 2007, 2009 Helge Kreutzmann + 2006, 2007, 2009, 2020 Helge Kreutzmann 2005-2010 Clytie Siddall 2005-2009 Debian French l10n team 2005, 2009, 2010 Christian Perrier @@ -60,6 +71,22 @@ 2002 Felix Kröger License: GPL-2.0+ +Files: t/lib/Devel/Autoflush.pm +Copyright: 2014 David Golden +License: Apache-2.0 + +Files: + t/lib/Test/* + t/lib/Test2.pm + t/lib/Test2/* + t/lib/ok.pm +Copyright: 2019 Chad Granum +License: Artistic or GPL-1+ + +Files: t/lib/ddclient/Test/Fake/HTTPD.pm +Copyright: 2011-2017 NAKAGAWA Masaki +License: Artistic or GPL-1+ + License: GPL-2.0+ This package is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -76,3 +103,35 @@ . On Debian systems, the complete text of the GNU General Public License version 2 can be found in "/usr/share/common-licenses/GPL-2". + +License: Apache-2.0 + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + . + http://www.apache.org/licenses/LICENSE-2.0 + . + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + . + On Debian systems, the complete text of version 2.0 of the Apache + License can be found in "/usr/share/common-licenses/Apache-2.0". + +License: Artistic + This program is free software; you can redistribute it and/or modify + it under the terms of the Artistic License, which comes with Perl. + . + On Debian systems, the complete text of the Artistic License can be + found in "/usr/share/common-licenses/Artistic". + +License: GPL-1+ + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + . + On Debian systems, the complete text of version 1 of the GNU General + Public License can be found in "/usr/share/common-licenses/GPL-1". diff -Nru ddclient-3.9.1/debian/ddclient.dhclient-exit-hook ddclient-3.10.0/debian/ddclient.dhclient-exit-hook --- ddclient-3.9.1/debian/ddclient.dhclient-exit-hook 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.dhclient-exit-hook 2023-01-16 02:47:24.000000000 +0000 @@ -3,7 +3,7 @@ # Run inside subshell so we can use exit to bail. ( - [ -x /usr/sbin/ddclient ] || exit 0 + [ -x /usr/bin/ddclient ] || exit 0 [ -f /etc/default/ddclient ] || exit 0 . /etc/default/ddclient [ "$run_dhclient" = "true" ] || exit 0 @@ -11,7 +11,7 @@ case $reason in BOUND|RENEW|REBIND) /usr/bin/logger -t dhclient "$reason, updating IP address with ddclient" - /usr/sbin/ddclient -daemon=0 -syslog > /dev/null 2>&1 + /usr/bin/ddclient -daemon=0 -syslog > /dev/null 2>&1 ;; *) ;; diff -Nru ddclient-3.9.1/debian/ddclient.init ddclient-3.10.0/debian/ddclient.init --- ddclient-3.9.1/debian/ddclient.init 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.init 2023-01-16 02:47:24.000000000 +0000 @@ -15,7 +15,7 @@ PATH=/sbin:/bin:/usr/sbin:/usr/bin NAME="ddclient" -DAEMON=/usr/sbin/$NAME +DAEMON=/usr/bin/$NAME PERL=/usr/bin/perl DESC="Dynamic DNS service update utility" @@ -53,7 +53,7 @@ start-stop-daemon --start \ --pidfile "$PIDFILE" --exec "$PERL" --startas "$DAEMON" \ - -- "$OPTIONS" \ + -- $OPTIONS \ || return 2 } diff -Nru ddclient-3.9.1/debian/ddclient.install ddclient-3.10.0/debian/ddclient.install --- ddclient-3.9.1/debian/ddclient.install 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.install 2023-01-16 02:47:24.000000000 +0000 @@ -1,3 +1,2 @@ #!/usr/bin/dh-exec -ddclient usr/sbin debian/ddclient.dhclient-exit-hook => etc/dhcp/dhclient-exit-hooks.d/ddclient diff -Nru ddclient-3.9.1/debian/ddclient.lintian-overrides ddclient-3.10.0/debian/ddclient.lintian-overrides --- ddclient-3.9.1/debian/ddclient.lintian-overrides 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.lintian-overrides 2023-01-16 02:47:24.000000000 +0000 @@ -1 +1,3 @@ -ddclient: duplicate-updaterc.d-calls-in-postinst ddclient +# Lintian limitation: The two calls to update-rc.d are in two different branches +# of an `if` statement so it's not actually called twice. +ddclient: duplicate-updaterc.d-calls-in-postinst ddclient [postinst:*] diff -Nru ddclient-3.9.1/debian/ddclient.ppp.ip-up ddclient-3.10.0/debian/ddclient.ppp.ip-up --- ddclient-3.9.1/debian/ddclient.ppp.ip-up 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.ppp.ip-up 2023-01-16 02:47:24.000000000 +0000 @@ -12,7 +12,7 @@ # only run ddclient, if it is installed ;-) -if [ ! -x /usr/sbin/ddclient ]; then +if [ ! -x /usr/bin/ddclient ]; then exit 0 fi @@ -34,4 +34,4 @@ # Run ddclient with the IP address of the ppp device -/usr/sbin/ddclient -syslog -ip $PPP_LOCAL +/usr/bin/ddclient -syslog -ip $PPP_LOCAL diff -Nru ddclient-3.9.1/debian/ddclient.service ddclient-3.10.0/debian/ddclient.service --- ddclient-3.9.1/debian/ddclient.service 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.service 2023-01-16 02:47:24.000000000 +0000 @@ -9,7 +9,7 @@ PIDFile=/run/ddclient.pid Environment=daemon_interval=5m EnvironmentFile=-/etc/default/ddclient -ExecStart=/usr/sbin/ddclient -daemon $daemon_interval -syslog -pid /run/ddclient.pid +ExecStart=/usr/bin/ddclient -daemon $daemon_interval -syslog -pid /run/ddclient.pid Restart=on-failure [Install] diff -Nru ddclient-3.9.1/debian/ddclient.templates ddclient-3.10.0/debian/ddclient.templates --- ddclient-3.9.1/debian/ddclient.templates 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/ddclient.templates 2023-01-16 02:47:24.000000000 +0000 @@ -25,8 +25,8 @@ Template: ddclient/protocol Type: select -#flag:translate:25 -__Choices: changeip, cloudflare, concont, dnsmadeeasy, dnspark, dondominio, dslreports1, dtdns, duckdns, dyndns1, dyndns2, easydns, freedns, freemyip, googledomains, hammernode1, namecheap, nfsn, noip, nsupdate, sitelutions, woima, yandex, zoneedit1, other +#flag:translate:31 +__Choices: 1984, changeip, cloudflare, cloudns, dinahosting, dnsexit, dnsmadeeasy, dondominio, dslreports1, duckdns, dyndns1, dyndns2, easydns, freedns, freemyip, gandi, godaddy, googledomains, hetzner, keysystems, namecheap, nfsn, njalla, noip, nsupdate, ovh, sitelutions, woima, yandex, zoneedit1, other Default: dyndns2 _Description: Dynamic DNS update protocol: Dynamic DNS update protocol used by your dynamic DNS service diff -Nru ddclient-3.9.1/debian/dirs ddclient-3.10.0/debian/dirs --- ddclient-3.9.1/debian/dirs 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/dirs 2023-01-16 02:47:24.000000000 +0000 @@ -1,4 +1,3 @@ -usr/sbin var/cache/ddclient etc/ppp/ip-up.d etc/dhcp/dhclient-exit-hooks.d diff -Nru ddclient-3.9.1/debian/examples ddclient-3.10.0/debian/examples --- ddclient-3.9.1/debian/examples 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/examples 2023-01-16 02:47:24.000000000 +0000 @@ -1,5 +1,4 @@ sample-ddclient-wrapper.sh sample-etc_cron.d_ddclient -sample-etc_ddclient.conf sample-etc_dhcpc_dhcpcd-eth0.exe sample-get-ip-from-fritzbox diff -Nru ddclient-3.9.1/debian/patches/boolean-parse.patch ddclient-3.10.0/debian/patches/boolean-parse.patch --- ddclient-3.9.1/debian/patches/boolean-parse.patch 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/boolean-parse.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -From: Richard Hansen -Date: Tue, 16 Jun 2020 22:58:09 -0400 -Subject: Fix parsing of "true" as a boolean value - -Before, "t" and "ttrue" were accepted as true, but not "true". - -Also simplify the true and false regular expressions. - -Origin: upstream, https://github.com/ddclient/ddclient/commit/40f355d05ef8f0a194f100784216fe1e928e8394 ---- - ddclient | 4 ++-- - 1 file changed, 2 insertions(+), 2 deletions(-) - -diff --git a/ddclient b/ddclient -index 5e4876d..655b0aa 100755 ---- a/ddclient -+++ b/ddclient -@@ -1897,9 +1897,9 @@ sub check_value { - $value = $min if defined($min) && $value < $min; - - } elsif ($type eq T_BOOL) { -- if ($value =~ /^y(es)?$|^t(true)?$|^1$/i) { -+ if ($value =~ /^(y(es)?|t(rue)?|1)$/i) { - $value = 1; -- } elsif ($value =~ /^n(o)?$|^f(alse)?$|^0$/i) { -+ } elsif ($value =~ /^(n(o)?|f(alse)?|0)$/i) { - $value = 0; - } else { - return undef; diff -Nru ddclient-3.9.1/debian/patches/config_path.diff ddclient-3.10.0/debian/patches/config_path.diff --- ddclient-3.9.1/debian/patches/config_path.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/config_path.diff 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -From: Torsten Landschoff -Date: Wed, 5 Apr 2006 02:01:22 +0200 -Subject: From version 3.6.7-1, config_path.diff - -Forwarded: no ---- - ddclient | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/ddclient b/ddclient -index 4a2d06c..f2acbfc 100755 ---- a/ddclient -+++ b/ddclient -@@ -33,7 +33,7 @@ my $program = $programd; - $program =~ s/d$//; - my $now = time; - my $hostname = hostname(); --my $etc = ($program =~ /test/i) ? './' : '/etc/ddclient/'; -+my $etc = ($program =~ /test/i) ? './' : '/etc/'; - my $cachedir = ($program =~ /test/i) ? './' : '/var/cache/ddclient/'; - my $savedir = ($program =~ /test/i) ? 'URL/' : '/tmp/'; - my $msgs = ''; diff -Nru ddclient-3.9.1/debian/patches/devices.patch ddclient-3.10.0/debian/patches/devices.patch --- ddclient-3.9.1/debian/patches/devices.patch 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/devices.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -From: Geoff Simmons -Date: Fri, 23 Jul 2010 03:11:17 +1000 -Subject: Add new device built-ins (`fw=`) - -Forwarded: https://github.com/ddclient/ddclient/pull/263 -Applied-Upstream: https://github.com/ddclient/ddclient/commit/f8185182e97d7fda6c920e2c4ec94c3f3e7d69f0 ---- - ddclient | 20 ++++++++++++++++++++ - 1 file changed, 20 insertions(+) - -diff --git a/ddclient b/ddclient -index 984fc4f..82b3d10 100755 ---- a/ddclient -+++ b/ddclient -@@ -178,6 +178,11 @@ my %builtinfw = ( - 'url' => '/cgi/ip/', - 'skip' => 'ppp', - }, -+ 'alcatel-530' => { -+ 'name' => 'Alcatel/Thomson SpeedTouch 530', -+ 'url' => '/cgi/status/', -+ 'skip' => 'IP Address', -+ }, - 'allnet-1298' => { - 'name' => 'Allnet 1298', - 'url' => '/cgi/router/', -@@ -198,6 +203,16 @@ my %builtinfw = ( - 'url' => '/shell/show+ip+interfaces', - 'skip' => '.*inet', - }, -+ 'thomson-st536v6' => { -+ 'name' => 'Thomson SpeedTouch 536v6', -+ 'url' => '/cgi/b/is/', -+ 'skip' => 'IP Address', -+ }, -+ 'thomson-tg782' => { -+ 'name' => 'Thomson/Technicolor TG782', -+ 'url' => '/cgi/b/is/', -+ 'skip' => 'IP Address', -+ }, - 'vigor-2200usb' => { - 'name' => 'Vigor 2200 USB', - 'url' => '/doc/online.sht', -@@ -288,6 +303,11 @@ my %builtinfw = ( - 'url' => '/status_main.stm', - 'skip' => 'var wan_ip=', - }, -+ 'siemens-ss4200' => { -+ 'name' => 'Siemens SpeedStream 4200', -+ 'url' => '/summary.htm', -+ 'skip' => '', -+ }, - 'sitecom-dc202' => { - 'name' => 'Sitecom DC-202 FW', - 'url' => '/status.htm', diff -Nru ddclient-3.9.1/debian/patches/dslreports.patch ddclient-3.10.0/debian/patches/dslreports.patch --- ddclient-3.9.1/debian/patches/dslreports.patch 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/dslreports.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -From: Richard Hansen -Date: Sat, 1 Aug 2020 16:22:38 -0400 -Subject: Change the default server for `dslreports1` to `www.dslreports.com` - -Before, it defaulted to `members.dyndns.org` which didn't make much -sense. - -Forwarded: https://github.com/ddclient/ddclient/pull/264 -Applied-Upstream: https://github.com/ddclient/ddclient/commit/25a636879f922234cb7ec8f1aa945f74d7cd2a38 ---- - ddclient | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/ddclient b/ddclient -index 71e69be..cfda556 100755 ---- a/ddclient -+++ b/ddclient -@@ -569,6 +569,7 @@ my %services = ( - 'update' => \&nic_dslreports1_update, - 'examples' => \&nic_dslreports1_examples, - 'variables' => merge( -+ { 'server' => setv(T_FQDNP, 1, 0, 1, 'www.dslreports.com', undef) }, - { 'host' => setv(T_NUMBER, 1, 1, 1, 0, undef) }, - $variables{'service-common-defaults'}, - ), -@@ -3195,7 +3196,6 @@ Configuration variables applicable to the 'dslreports1' protocol are: - Example ${program}.conf file entries: - ## single host update - protocol=dslreports1, \\ -- server=www.dslreports.com, \\ - login=my-dslreports-login, \\ - password=my-dslreports-password \\ - 123456 diff -Nru ddclient-3.9.1/debian/patches/fix-default-interface-tests.diff ddclient-3.10.0/debian/patches/fix-default-interface-tests.diff --- ddclient-3.9.1/debian/patches/fix-default-interface-tests.diff 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/fix-default-interface-tests.diff 2023-01-16 02:47:24.000000000 +0000 @@ -0,0 +1,65 @@ +From: Richard Hansen +Date: Wed, 23 Nov 2022 02:11:16 -0500 +Subject: Fix flawed default interface IP address tests + +`ddclient::get_default_interface()` doesn't appear to return anything +on the salsa.debian.org CI runners, and subtests can't have 0 +checks. + +Also, some systems don't have IPv4 or IPv6 addresses on the default +interface. + +Forwarded: no +--- + t/get_ip_from_if.pl | 37 +++++++++++++++++++------------------ + 1 file changed, 19 insertions(+), 18 deletions(-) + +diff --git a/t/get_ip_from_if.pl b/t/get_ip_from_if.pl +index 6f08e5d..cc0cabf 100644 +--- a/t/get_ip_from_if.pl ++++ b/t/get_ip_from_if.pl +@@ -39,25 +39,26 @@ subtest "get_ip_from_interface tests" => sub { + } + }; + +-subtest "Get default interface and IP for test system" => sub { ++subtest "Get default interface and IP for test system (IPv4)" => sub { + my $interface = ddclient::get_default_interface(4); +- if ($interface) { +- isnt($interface, "lo", "Check for loopback 'lo'"); +- isnt($interface, "lo0", "Check for loopback 'lo0'"); +- my $ip1 = ddclient::get_ip_from_interface("default", 4); +- my $ip2 = ddclient::get_ip_from_interface($interface, 4); +- is($ip1, $ip2, "Check IPv4 from default interface"); +- ok(ddclient::is_ipv4($ip1), "Valid IPv4 from get_ip_from_interface($interface)"); +- } +- $interface = ddclient::get_default_interface(6); +- if ($interface) { +- isnt($interface, "lo", "Check for loopback 'lo'"); +- isnt($interface, "lo0", "Check for loopback 'lo0'"); +- my $ip1 = ddclient::get_ip_from_interface("default", 6); +- my $ip2 = ddclient::get_ip_from_interface($interface, 6); +- is($ip1, $ip2, "Check IPv6 from default interface"); +- ok(ddclient::is_ipv6($ip1), "Valid IPv6 from get_ip_from_interface($interface)"); +- } ++ plan skip_all => 'no IPv4 interface' if !$interface; ++ isnt($interface, "lo", "Check for loopback 'lo'"); ++ isnt($interface, "lo0", "Check for loopback 'lo0'"); ++ my $ip1 = ddclient::get_ip_from_interface("default", 4); ++ my $ip2 = ddclient::get_ip_from_interface($interface, 4); ++ is($ip1, $ip2, "Check IPv4 from default interface"); ++ ok(!$ip1 || ddclient::is_ipv4($ip1), "Valid IPv4 from get_ip_from_interface($interface)"); ++}; ++ ++subtest "Get default interface and IP for test system (IPv6)" => sub { ++ my $interface = ddclient::get_default_interface(6); ++ plan skip_all => 'no IPv6 interface' if !$interface; ++ isnt($interface, "lo", "Check for loopback 'lo'"); ++ isnt($interface, "lo0", "Check for loopback 'lo0'"); ++ my $ip1 = ddclient::get_ip_from_interface("default", 6); ++ my $ip2 = ddclient::get_ip_from_interface($interface, 6); ++ is($ip1, $ip2, "Check IPv6 from default interface"); ++ ok(!$ip1 || ddclient::is_ipv6($ip1), "Valid IPv6 from get_ip_from_interface($interface)"); + }; + + done_testing(); diff -Nru ddclient-3.9.1/debian/patches/fix-version.diff ddclient-3.10.0/debian/patches/fix-version.diff --- ddclient-3.9.1/debian/patches/fix-version.diff 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/fix-version.diff 2023-01-16 02:47:24.000000000 +0000 @@ -0,0 +1,20 @@ +From: Richard Hansen +Date: Wed, 23 Nov 2022 00:57:53 -0500 +Subject: Fix version in configure.ac + +Forwarded: not-needed +--- + configure.ac | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/configure.ac b/configure.ac +index 554ea6b..c825436 100644 +--- a/configure.ac ++++ b/configure.ac +@@ -1,5 +1,5 @@ + AC_PREREQ([2.63]) +-AC_INIT([ddclient], [3.10.0_2]) ++AC_INIT([ddclient], [3.10.0]) + AC_CONFIG_SRCDIR([ddclient.in]) + AC_CONFIG_AUX_DIR([build-aux]) + AC_CONFIG_MACRO_DIR([m4]) diff -Nru ddclient-3.9.1/debian/patches/maxinterval.diff ddclient-3.10.0/debian/patches/maxinterval.diff --- ddclient-3.9.1/debian/patches/maxinterval.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/maxinterval.diff 2023-01-16 02:47:24.000000000 +0000 @@ -4,19 +4,19 @@ Forwarded: no --- - ddclient | 2 +- + ddclient.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) -diff --git a/ddclient b/ddclient -index f2acbfc..3b40f57 100755 ---- a/ddclient -+++ b/ddclient -@@ -393,7 +393,7 @@ my %variables = ( - 'atime' => setv(T_NUMBER, 0, 1, 0, 0, undef), - 'status' => setv(T_ANY, 0, 1, 0, '', undef), - 'min-interval' => setv(T_DELAY, 0, 0, 1, interval('30s'), 0), -- 'max-interval' => setv(T_DELAY, 0, 0, 1, interval('25d'), 0), -+ 'max-interval' => setv(T_DELAY, 0, 0, 1, interval('30d'), 0), - 'min-error-interval' => setv(T_DELAY, 0, 0, 1, interval('5m'), 0), +diff --git a/ddclient.in b/ddclient.in +index 6687f8b..bdd4bd9 100755 +--- a/ddclient.in ++++ b/ddclient.in +@@ -511,7 +511,7 @@ my %variables = ( + 'status-ipv4' => setv(T_ANY, 0, 1, '', undef), + 'status-ipv6' => setv(T_ANY, 0, 1, '', undef), + 'min-interval' => setv(T_DELAY, 0, 0, interval('30s'), 0), +- 'max-interval' => setv(T_DELAY, 0, 0, interval('25d'), 0), ++ 'max-interval' => setv(T_DELAY, 0, 0, interval('30d'), 0), + 'min-error-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), - 'warned-min-interval' => setv(T_ANY, 0, 1, 0, 0, undef), + 'warned-min-interval' => setv(T_ANY, 0, 1, 0, undef), diff -Nru ddclient-3.9.1/debian/patches/news.diff ddclient-3.10.0/debian/patches/news.diff --- ddclient-3.9.1/debian/patches/news.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/news.diff 2023-01-16 02:47:24.000000000 +0000 @@ -1,6 +1,6 @@ From: Richard Hansen Date: Sat, 23 May 2020 16:21:16 -0400 -Subject: Rename RELEASENOTE to NEWS +Subject: Rename ChangeLog.md to NEWS This ensures that the file is installed as NEWS.gz as required in Debian policy >= 4.2.0. For details, see: @@ -8,11 +8,11 @@ Forwarded: no --- - RELEASENOTE => NEWS | 0 + ChangeLog.md => NEWS | 0 1 file changed, 0 insertions(+), 0 deletions(-) - rename RELEASENOTE => NEWS (100%) + rename ChangeLog.md => NEWS (100%) -diff --git a/RELEASENOTE b/NEWS +diff --git a/ChangeLog.md b/NEWS similarity index 100% -rename from RELEASENOTE +rename from ChangeLog.md rename to NEWS diff -Nru ddclient-3.9.1/debian/patches/series ddclient-3.10.0/debian/patches/series --- ddclient-3.9.1/debian/patches/series 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/series 2023-01-16 02:47:24.000000000 +0000 @@ -1,10 +1,5 @@ -shebang.diff news.diff -smc-barricade-fw-alt.diff -config_path.diff maxinterval.diff -usev6.diff -boolean-parse.patch -use-ipv4.patch -devices.patch -dslreports.patch +fix-version.diff +fix-default-interface-tests.diff +ssl-hostname-verification.patch diff -Nru ddclient-3.9.1/debian/patches/shebang.diff ddclient-3.10.0/debian/patches/shebang.diff --- ddclient-3.9.1/debian/patches/shebang.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/shebang.diff 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -From: Richard Hansen -Date: Sat, 23 May 2020 14:33:22 -0400 -Subject: Set shebang as required by Debian policy >= 4.1.2 - -See https://www.debian.org/doc/debian-policy/ch-files.html#scripts - -Forwarded: https://github.com/ddclient/ddclient/pull/116 ---- - ddclient | 4 ++-- - 1 file changed, 2 insertions(+), 2 deletions(-) - -diff --git a/ddclient b/ddclient -index 8a1bacc..144cdd3 100755 ---- a/ddclient -+++ b/ddclient -@@ -1,5 +1,4 @@ --#!/usr/bin/perl -w --#!/usr/local/bin/perl -w -+#!/usr/bin/perl - ###################################################################### - # - # DDCLIENT - a Perl client for updating DynDNS information -@@ -21,6 +20,7 @@ - ###################################################################### - require 5.004; - use strict; -+use warnings; - use Getopt::Long; - use Sys::Hostname; - use IO::Socket; diff -Nru ddclient-3.9.1/debian/patches/smc-barricade-fw-alt.diff ddclient-3.10.0/debian/patches/smc-barricade-fw-alt.diff --- ddclient-3.9.1/debian/patches/smc-barricade-fw-alt.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/smc-barricade-fw-alt.diff 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -From: Torsten Landschoff -Date: Fri, 10 Aug 2012 02:10:02 +0200 -Subject: From version 3.6.7-1, smc-barricade-fw-alt.diff - -Forwarded: no ---- - ddclient | 5 +++++ - 1 file changed, 5 insertions(+) - -diff --git a/ddclient b/ddclient -index 144cdd3..4a2d06c 100755 ---- a/ddclient -+++ b/ddclient -@@ -92,6 +92,11 @@ my %builtinfw = ( - 'url' => '/status.HTM', - 'skip' => 'WAN IP', - }, -+ 'smc-barricade-alt' => { -+ 'name' => 'SMC Barricade FW (alternate config)', -+ 'url' => '/status.HTM', -+ 'skip' => 'WAN IP', -+ }, - 'smc-barricade-7401bra' => { - 'name' => 'SMC Barricade 7401BRA FW', - 'url' => '/admin/wan1.htm', diff -Nru ddclient-3.9.1/debian/patches/ssl-hostname-verification.patch ddclient-3.10.0/debian/patches/ssl-hostname-verification.patch --- ddclient-3.9.1/debian/patches/ssl-hostname-verification.patch 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/ssl-hostname-verification.patch 2023-01-16 02:47:24.000000000 +0000 @@ -0,0 +1,156 @@ +From: Richard Hansen +Date: Sun, 15 Jan 2023 20:15:07 -0500 +Subject: Set `SSL_verifycn_scheme` and `SSL_verifycn_name` on SSL connection + +IO::Socket::SSL recently changed hostname verification of literal IP +addresses; see . +Literal IP addresses are unlikely to be used by users, but they are +used in unit tests, so the tests started failing. To fix the tests, +and to fix any rare non-test usages, unconditionally set +`SSL_verify_name` to the peer hostname or IP address literal. + +While we're here, set `SSL_verifycn_scheme` to `"http"` as encouraged +by the IO::Socket::SSL documentation. + +Bug: https://github.com/noxxi/p5-io-socket-ssl/issues/123 +Bug-Debian: https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1028849 +Forwarded: no +--- + ddclient.in | 2 ++ + t/geturl_ssl.pl | 26 ++++++++++++++++++++++++++ + 2 files changed, 28 insertions(+) + +diff --git a/ddclient.in b/ddclient.in +index 28e2330..13a1a05 100755 +--- a/ddclient.in ++++ b/ddclient.in +@@ -2497,6 +2497,8 @@ sub fetch_via_socket_io { + $socket_args{SSL_verify_mode} = ($params{ssl_validate} // 1) + ? IO::Socket::SSL->SSL_VERIFY_PEER + : IO::Socket::SSL->SSL_VERIFY_NONE; ++ $socket_args{SSL_verifycn_scheme} = 'http'; ++ $socket_args{SSL_verifycn_name} = $peer; + } elsif ($globals{'ipv6'} || $ipversion eq '6') { + load_ipv6_support; + $socket_class = 'IO::Socket::INET6'; +diff --git a/t/geturl_ssl.pl b/t/geturl_ssl.pl +index c070def..d034c4b 100644 +--- a/t/geturl_ssl.pl ++++ b/t/geturl_ssl.pl +@@ -59,6 +59,8 @@ my @test_cases = ( + PeerAddr => 'hostname', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -72,6 +74,8 @@ my @test_cases = ( + PeerAddr => 'hostname', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -84,6 +88,8 @@ my @test_cases = ( + PeerAddr => 'hostname', + PeerPort => '123', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -97,6 +103,8 @@ my @test_cases = ( + PeerAddr => 'hostname', + PeerPort => '123', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -110,6 +118,8 @@ my @test_cases = ( + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_uri => 'http://hostname/', + todo => "broken", +@@ -124,6 +134,8 @@ my @test_cases = ( + PeerAddr => 'proxy', + PeerPort => '80', + SSL_startHandshake => 0, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', +@@ -139,6 +151,8 @@ my @test_cases = ( + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', +@@ -155,6 +169,8 @@ my @test_cases = ( + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', +@@ -169,6 +185,8 @@ my @test_cases = ( + want_args => { + PeerAddr => 'proxy', + PeerPort => '123', ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_uri => 'http://hostname:456/', + todo => "broken", +@@ -183,6 +201,8 @@ my @test_cases = ( + PeerAddr => 'proxy', + PeerPort => '123', + SSL_startHandshake => 0, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'proxy', + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:456', +@@ -199,6 +219,8 @@ my @test_cases = ( + PeerPort => '443', + SSL_ca_path => '/ca/dir', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -213,6 +235,8 @@ my @test_cases = ( + PeerPort => '443', + SSL_ca_file => '/ca/file', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, +@@ -229,6 +253,8 @@ my @test_cases = ( + SSL_ca_file => '/ca/file', + SSL_ca_path => '/ca/dir', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, ++ SSL_verifycn_scheme => 'http', ++ SSL_verifycn_name => 'hostname', + }, + want_req_uri => '/', + }, diff -Nru ddclient-3.9.1/debian/patches/use-ipv4.patch ddclient-3.10.0/debian/patches/use-ipv4.patch --- ddclient-3.9.1/debian/patches/use-ipv4.patch 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/use-ipv4.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -From: Richard Hansen -Date: Tue, 16 Jun 2020 22:59:51 -0400 -Subject: Fix `use=ip` when `ip` is set to an IPv4 address - -Before, with `use=ip,ip=1.2.3.4`, `get_ip` would return `undef` and -print a warning: - - WARNING: found neither ipv4 nor ipv6 address - -Origin: upstream, https://github.com/ddclient/ddclient/commit/99a60995c47348ea3281cf992f1605712b1c7598 ---- - ddclient | 4 +++- - 1 file changed, 3 insertions(+), 1 deletion(-) - -diff --git a/ddclient b/ddclient -index 655b0aa..984fc4f 100755 ---- a/ddclient -+++ b/ddclient -@@ -2326,7 +2326,9 @@ sub get_ip { - $skip =~ s/ /\\s/is; - $reply =~ s/^.*?${skip}//is; - } -- if ($reply =~ /^.*?\b(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\b.*/is) { -+ if (defined($ip)) { -+ # no need to parse $reply -+ } elsif ($reply =~ /^.*?\b(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\b.*/is) { - $ip = $1; - $ip = un_zero_pad($ip); - $ip = filter_local($ip) if opt('fw-banlocal', $h); diff -Nru ddclient-3.9.1/debian/patches/usev6.diff ddclient-3.10.0/debian/patches/usev6.diff --- ddclient-3.9.1/debian/patches/usev6.diff 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/patches/usev6.diff 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -From: Torsten Landschoff -Date: Sun, 18 Jan 2015 20:54:02 +0100 -Subject: Add ipv6 support for dyndns -MIME-Version: 1.0 -Content-Type: text/plain; charset="utf-8" -Content-Transfer-Encoding: 8bit - -This adds a "usev6" variable to ddclient to support IPv6 updates -with dyndns and freedns. - -Author: Eduardo Trápani -Forwarded: no -Bug-Debian: https://bugs.debian.org/704467 ---- - ddclient | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------- - 1 file changed, 61 insertions(+), 8 deletions(-) - -diff --git a/ddclient b/ddclient -index 3b40f57..5e4876d 100755 ---- a/ddclient -+++ b/ddclient -@@ -59,6 +59,7 @@ sub T_FILE {'file name'}; - sub T_FQDNP {'fully qualified host name and optional port number'}; - sub T_PROTO {'protocol'} - sub T_USE {'ip strategy'} -+sub T_USEV6 {'ipv6 strategy'} - sub T_IF {'interface'} - sub T_PROG {'program name'} - sub T_IP {'ip'} -@@ -334,6 +335,7 @@ my %variables = ( - 'protocol' => setv(T_PROTO, 0, 0, 1, 'dyndns2', undef), - - 'use' => setv(T_USE, 0, 0, 1, 'ip', undef), -+ 'usev6' => setv(T_USEV6, 0, 0, 1, undef, undef), - 'ip' => setv(T_IP, 0, 0, 1, undef, undef), - 'if' => setv(T_IF, 0, 0, 1, 'ppp0', undef), - 'if-skip' => setv(T_STRING,1, 0, 1, '', undef), -@@ -375,6 +377,7 @@ my %variables = ( - 'host' => setv(T_STRING, 1, 1, 1, '', undef), - - 'use' => setv(T_USE, 0, 0, 1, 'ip', undef), -+ 'usev6' => setv(T_USE, 0, 0, 1, undef, undef), - 'if' => setv(T_IF, 0, 0, 1, 'ppp0', undef), - 'if-skip' => setv(T_STRING,0, 0, 1, '', undef), - 'web' => setv(T_STRING,0, 0, 1, 'dyndns', undef), -@@ -759,7 +762,8 @@ my @opt = ( - [ "cache", "=s", "-cache path : record address used in 'path'" ], - [ "pid", "=s", "-pid path : record process id in 'path'" ], - "", -- [ "use", "=s", "-use which : how the should IP address be obtained." ], -+ [ "use", "=s", "-use which : how should the IP address be obtained." ], -+ [ "usev6", "=s", "-usev6 which : how should the IPv6 address be obtained." ], - &ip_strategies_usage(), - "", - [ "ip", "=s", "-ip address : set the IP address to 'address'" ], -@@ -957,7 +961,8 @@ sub update_nics { - next if $config{$h}{'protocol'} ne lc($s); - $examined{$h} = 1; - # we only do this once per 'use' and argument combination -- my $use = opt('use', $h); -+ my $ipv6 = defined($config{$h}{'usev6'}); -+ my $use = $ipv6 ? opt('usev6', $h) : opt('use', $h); - my $arg_ip = opt('ip', $h) || ''; - my $arg_fw = opt('fw', $h) || ''; - my $arg_if = opt('if', $h) || ''; -@@ -967,17 +972,20 @@ sub update_nics { - if (exists $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}) { - $ip = $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd}; - } else { -- $ip = get_ip($use, $h); -+ $ip = get_ip($use, $h) if !$ipv6; -+ $ip = get_ipv6($use, $h) if $ipv6; - if (!defined $ip || !$ip) { - warning("unable to determine IP address") - if !$daemon || opt('verbose'); - next; - } -- if ($ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { -- if( !ipv6_match($ip) ) { -- warning("malformed IP address (%s)", $ip); -- next; -- } -+ if (!$ipv6 and $ip !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) { -+ warning("malformed IPv4 address (%s)", $ip); -+ next; -+ } -+ if ($ipv6 and !ipv6_match($ip)) { -+ warning("malformed IPv6 address (%s)", $ip); -+ next; - } - $iplist{$use}{$arg_ip}{$arg_fw}{$arg_if}{$arg_web}{$arg_cmd} = $ip; - } -@@ -1297,6 +1305,11 @@ sub init_config { - $opt{'use'} = 'if' if !define($opt{'use'}) && defined($opt{'if'}); - $opt{'use'} = 'web' if !define($opt{'use'}) && defined($opt{'web'}); - -+ ## infer the IPv6 strategy if possible -+ $opt{'usev6'} = 'ip' if !define($opt{'usev6'}) && defined($opt{'ip'}); -+ $opt{'usev6'} = 'if' if !define($opt{'usev6'}) && defined($opt{'if'}); -+ $opt{'usev6'} = 'web' if !define($opt{'usev6'}) && defined($opt{'web'}); -+ - ## sanity check - $opt{'max-interval'} = min(interval(opt('max-interval')), interval(default('max-interval'))); - $opt{'min-interval'} = max(interval(opt('min-interval')), interval(default('min-interval'))); -@@ -1907,6 +1920,10 @@ sub check_value { - $value = lc $value; - return undef if ! exists $ip_strategies{$value}; - -+ } elsif ($type eq T_USEV6) { -+ $value = lc $value; -+ return undef if ! exists $ip_strategies{$value}; -+ - } elsif ($type eq T_FILE) { - return undef if $value eq ""; - -@@ -2327,6 +2344,42 @@ sub get_ip { - return $ip; - } - -+###################################################################### -+## get_ipv6 -+###################################################################### -+sub get_ipv6 { -+ my $use = lc shift; -+ my $h = shift; -+ my ($ip, $arg, $reply, $url, $skip) = (undef, opt($use, $h), ''); -+ $arg = '' unless $arg; -+ -+ if ($use eq 'ip') { -+ $ip = opt('ip', $h); -+ $arg = 'ip'; -+ -+ } elsif ($use eq 'if') { -+ $skip = opt('if-skip', $h) || ''; -+ $reply = `ip -6 addr list dev "$arg" scope global -tentative -deprecated -dadfailed | grep inet6 | grep -v temporary | grep -v "inet6 f[cd]" 2> /dev/null`; -+ $reply = '' if $?; -+ } -+ if (!defined $reply) { -+ $reply = ''; -+ } -+ if ($skip) { -+ $skip =~ s/ /\\s/is; -+ $reply =~ s/^.*?${skip}//is; -+ } -+ if ($reply =~ /.*? ([0-9:][^\/]*)/i) { -+ $ip = $1; -+ } -+ if (($use ne 'ip') && (define($ip,'') eq '0.0.0.0')) { -+ $ip = undef; -+ } -+ -+ debug("get_ipv6: using %s, %s reports %s", $use, $arg, define($ip, "")); -+ return $ip; -+} -+ - ###################################################################### - ## ipv6_match determine ipv6 address from given string and return them - ###################################################################### diff -Nru ddclient-3.9.1/debian/po/pt_PT.po ddclient-3.10.0/debian/po/pt_PT.po --- ddclient-3.9.1/debian/po/pt_PT.po 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/po/pt_PT.po 2023-01-16 02:47:24.000000000 +0000 @@ -1,22 +1,22 @@ -# ddclient Portuguese translation -# Copyright (C) 2010 THE ddclient'S COPYRIGHT HOLDER +# Translation of ddclient debconf messages to European Portuguese +# Copyright (C) 2021 THE ddclient'S COPYRIGHT HOLDER # This file is distributed under the same license as the ddclient package. -# Flamarion Jorge , 2009, 2010. -# José Vieira , 2020. # +# Américo Monteiro , 2021. msgid "" msgstr "" "Project-Id-Version: ddclient 3.9.1-7\n" "Report-Msgid-Bugs-To: ddclient@packages.debian.org\n" "POT-Creation-Date: 2020-08-05 18:23-0400\n" -"PO-Revision-Date: 2020-08-20 20:06-0300\n" -"Last-Translator: José Vieira \n" -"Language-Team: Portuguese \n" +"PO-Revision-Date: 2021-02-08 21:34+0000\n" +"Last-Translator: Américo Monteiro \n" +"Language-Team: Portuguese \n" "Language: pt_PT\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" +"X-Generator: Lokalize 2.0\n" #. Type: select #. Choices @@ -33,44 +33,33 @@ #. Description #: ../ddclient.templates:2002 msgid "Dynamic DNS service provider:" -msgstr "Fornecedor de serviço de DNS dinâmico:" +msgstr "Fornecedor do serviço Dynamic DNS:" #. Type: select #. Description #: ../ddclient.templates:2002 -#| msgid "" -#| "Please select the dynamic DNS service you are using. If the service -you " -#| "use is not listed, choose \"other\" and you will be asked for the " -#| "protocol and the server name." msgid "" "Dynamic DNS service you are using. If the service you use is not listed, " "choose \"other\"." msgstr "" -"Serviço de DNS dinâmico em uso. Se o serviço a usar -não " -"estiver na lista, escolher \"outro\"." +"O serviço Dynamic DNS que está a usar. Se o serviço que você usa não estiver " +"listado, escolha \"outro\"." #. Type: string #. Description #: ../ddclient.templates:3001 -#| msgid "Dynamic DNS server:" msgid "Dynamic DNS server (blank for default):" -msgstr "Servidor de DNS dinâmico (em branco = predefinição):" +msgstr "Servidor Dynamic DNS (vazio para predefinição):" #. Type: string #. Description #: ../ddclient.templates:3001 -#| msgid "" -#| "Please enter the name of the server which is providing you with -dynamic " -#| "DNS service (example: members.dyndns.org)." msgid "" "Server providing the dynamic DNS service (example: members.dyndns.org). " "Leave blank to use the default for the \"${protocol}\" protocol." msgstr "" "Servidor que fornece o serviço de DNS dinâmico (exemplo: members.dyndns.org). " -"Deixar em branco para usar a predefinição para o protocolo \"${protocol}\"." +"Deixe vazio para usar o predefinido para o protocolo \"${protocol}\"." #. Type: select #. Description @@ -78,147 +67,127 @@ #. Description #: ../ddclient.templates:4002 ../ddclient.templates:5001 msgid "Dynamic DNS update protocol:" -msgstr "Protocolo de actualização de DNS dinâmico:" +msgstr "Protocolo de actualização do Dynamic DNS:" #. Type: select #. Description #: ../ddclient.templates:4002 -#| msgid "" -#| "Please select the dynamic DNS update protocol used by your dynamic DNS " -#| "service provider." msgid "" "Dynamic DNS update protocol used by your dynamic DNS service provider. If " "the protocol your service uses is not listed, select \"other\"." msgstr "" -"Protocolo de actualização de DNS dinâmico utilizado pelo fornecedor do " -"serviço de DNS dinâmico. Se o protocolo usado pelo serviço não estiver " -"na lista, seleccionar \"outro\"." +"Protocolo de actualização de Dynamic DNS usado pelo seu fornecedor de " +"serviço de DNS dinâmico. Se o protocolo que o seu serviço usa não está " +"listado, selecione \"outro\"." #. Type: string #. Description #: ../ddclient.templates:5001 -#| msgid "" -#| "Please select the dynamic DNS update protocol used by your dynamic DNS " -#| "service provider." msgid "" -"The name of the dynamic DNS update protocol used by your dynamic DNS -service " +"The name of the dynamic DNS update protocol used by your dynamic DNS service " "provider." msgstr "" -"Nome do protocolo de actualização de DNS dinâmico utilizado pelo " -"fornecedor do serviço de DNS dinâmico." +"O nome do protocolo de actualização de DNS dinâmico usado pelo seu fornecedor " +"de serviço de DNS dinâmico." #. Type: string #. Description #: ../ddclient.templates:6001 msgid "Optional HTTP proxy:" -msgstr "Proxy HTTP opcional:" +msgstr "proxy HTTP opcional:" #. Type: string #. Description #: ../ddclient.templates:6001 msgid "" -"HTTP proxy in the form http://proxy.example.com - or https://proxy.example -." -"com. Proxy authentication is not supported. Leave blank if you do not -use an " +"HTTP proxy in the form http://proxy.example.com or https://proxy.example." +"com. Proxy authentication is not supported. Leave blank if you do not use an " "HTTP proxy." msgstr "" -"Proxy HTTP no formato http://proxy.example.com - ou https://proxy.example.com -. " -"Autenticação de proxy não suportada. Deixar em branco se não for usado nenhum " -"proxy HTTP." +"Proxy HTTP no formato http://proxy.example.com ou https://proxy.example." +"com. A autenticação de proxy não é suportada. Deixe vazio se você não usar " +"um proxy HTTP." #. Type: string #. Description #: ../ddclient.templates:7001 msgid "Hosts to update (comma-separated):" -msgstr "Hospedeiros a actualizar (separados por vírgulas):" +msgstr "Máquinas a actualizar (separadas por vírgulas):" #. Type: string #. Description #: ../ddclient.templates:7001 -#| msgid "" -#| "Please enter the list of fully qualified domain names for the local " -#| "host(s) (for instance, \"myname.dyndns.org\" with only one host or " -#| "\"myname1.dyndns.org,myname2.dyndns.org\" for two hosts)." msgid "" "Comma-separated list of fully qualified domain names to update (for " -"instance, \"myname.dyndns.org\" with only one host, or -\"myname1.dyndns.org," +"instance, \"myname.dyndns.org\" with only one host, or \"myname1.dyndns.org," "myname2.dyndns.org\" for two hosts)." msgstr "" -"Lista de nomes de domínio totalmente qualificados separados por vírgulas -(por " -"exemplo, \"meunome.dyndns.org\" para um hospedeiro ou " -"\"meunome1.dyndns.org,meunome2.dyndns.org\" para dois hospedeiros)." +"Lista separada por vírgulas dos nomes de domínio totalmente qualificados " +"para actualizar (por exemplo \"myname.dyndns.org\" com apenas uma máquina, " +"ou \"myname1.dyndns.org,myname2.dyndns.org\" para duas máquinas)." #. Type: string #. Description #: ../ddclient.templates:8001 msgid "Username:" -msgstr "Utilizador:" +msgstr "Nome de utilizador:" #. Type: string #. Description #: ../ddclient.templates:8001 -#| msgid "Please enter the username to use with the dynamic DNS service." msgid "" "Username (or other type of account identifer) to use with the dynamic DNS " "service." msgstr "" -"Nome de utilizador (ou outro tipo de identificador de conta) para o serviço " -"de DNS dinâmico." +"Nome de utilizador (ou outro tipo de identificador de conta) para usar " +"com o serviço de DNS dinâmico." #. Type: password #. Description #: ../ddclient.templates:9001 msgid "Password:" -msgstr "Senha:" +msgstr "Palavra passe:" #. Type: password #. Description #: ../ddclient.templates:9001 -#| msgid "Please enter the password to use with the dynamic DNS service." msgid "Password, API key, or token to use with the dynamic DNS service." -msgstr "Senha, chave de API ou código para o serviço de DNS dinâmico." +msgstr "" +"Palavra passe, chave API, ou testemunho a usar com o serviço de DNS dinâmico." #. Type: password #. Description #: ../ddclient.templates:10001 msgid "Re-enter password:" -msgstr "Reintroduzir a senha:" +msgstr "Re-insira a palavra-passe:" #. Type: password #. Description #: ../ddclient.templates:10001 -#| msgid "Please enter the password to use with the dynamic DNS service." msgid "" -"Password, API key, or token entered again to ensure it was entered -correctly." +"Password, API key, or token entered again to ensure it was entered correctly." msgstr "" -"Senha, chave de API ou código introduzido novamente para garantir que foi " -"introduzido corretamente." +"Palavra passe, chave API, ou testemunho inserido outra vez para assegurar " +"que foi inserido corretamente." #. Type: error #. Description #: ../ddclient.templates:11001 msgid "Passwords do not match" -msgstr "As senhas não coincidem" +msgstr "As palavras-passe não correspondem" #. Type: error #. Description #: ../ddclient.templates:11001 msgid "The two passwords you entered were not the same. Please try again." -msgstr "As senhas introduzidas não são iguais. Voltar a tentar." +msgstr "" +"As duas palavras-passe que inseriu não são iguais. Por favor tente de novo." #. Type: select #. Choices #: ../ddclient.templates:12001 msgid "Web-based IP discovery service" -msgstr "Serviço de descoberta de IP baseado na web" +msgstr "Serviço de descoberta de IP baseado em Web" #. Type: select #. Choices @@ -236,48 +205,44 @@ #. Description #: ../ddclient.templates:12002 msgid "" -"The method ddclient uses to determine your current IP address. Your -options:" +"The method ddclient uses to determine your current IP address. Your options:" msgstr "" -"Método que o ddclient usa para determinar o endereço IP em uso. Opções:" +"O método que o ddclient usa para determinar o seu endereço IP actual. A suas " +"opções:" #. Type: select #. Description #: ../ddclient.templates:12002 msgid "" "Web-based IP discovery service: Periodically visit a web page that shows " -"your IP address. You probably want this option if your computer is -connected " +"your IP address. You probably want this option if your computer is connected " "to the Internet via a Network Address Translation (NAT) device such as a " "typical consumer router." msgstr "" -"Serviço de descoberta de IP baseado na web: visita periodicamente uma " -"página web que mostra o endereço IP. Provavelmente será esta a -opção a escolher " -"se o computador estiver ligado à Internet através dum dispositivo NAT " -"(Network Address Translation), como seja um encaminhador (router) doméstico comum." +"Serviço de descoberta de IP baseado em Web: Periodicamente visita uma " +"página web que mostra o seu endereço IP. Provavelmente você vai querer esta " +"opção se o seu computador estiver ligado à Internet via dispositivo de " +"Network Address Translation (NAT) tal como um router típico de consumidor." #. Type: select #. Description #: ../ddclient.templates:12002 msgid "" "Network interface: Use the IP address assigned to your computer's network " -"interface (such as an Ethernet adapter or PPP connection). You probably -want " +"interface (such as an Ethernet adapter or PPP connection). You probably want " "this option if your computer connects directly to the Internet (your " "connection does not go through a NAT device)." msgstr "" -"Interface de rede: usar o endereço IP associado à interface de rede do " -"computador (por exemplo um adaptador Ethernet ou ligação PPP). " -"Provavelmente será esta a opção a escolher se o computador estiver ligado -directamente " -"à Internet (a ligação não passa por um dispositivo NAT)." +"Interface de rede: Use o endereço IP atribuído à interface de rede do seu " +"computador (tal como uma placa Ethernet ou ligação PPP). Provavelmente " +"você vai querer esta opção se o seu computador estiver ligado directamente " +"à Internet (a sua ligação não passa por um dispositivo NAT)." #. Type: select #. Description #: ../ddclient.templates:13002 msgid "IP discovery service:" -msgstr "Serviço de descoberta IP:" +msgstr "Serviço de descoberta de IP:" #. Type: select #. Description @@ -286,8 +251,8 @@ "The web-based IP discovery service you would like ddclient to use to " "determine your current IP address." msgstr "" -"Serviço de descoberta de IP baseado na web a usar pelo ddclient para " -"descobrir qual é o endereço IP em uso." +"O serviço de descoberta de IP baseado em web que você deseja que o ddclient " +"use para determinar o seu endereço IP actual." #. Type: string #. Description @@ -299,7 +264,7 @@ #. Description #: ../ddclient.templates:14001 msgid "URL to a web page that returns your IP address." -msgstr "URL para uma página web que mostra o endereço IP." +msgstr "URL para uma página web que retorna o seu endereço IP." #. Type: string #. Description @@ -314,45 +279,42 @@ "The name of the network interface (e.g., eth0, wlan0, ppp0) that ddclient " "will look at to determine the current IP address." msgstr "" -"Nome da interface de rede (p. ex., eth0, wlan0, ppp0) que o ddclient -usará " -"para descobrir qual é o endereço IP em uso." +"O nome da interface de rede (ex. eth0, wlan0, ppp0) que o ddclient irá " +"olhar para determinar o endereço IP actual." #. Type: select #. Choices #: ../ddclient.templates:16001 msgid "As a daemon" -msgstr "Como serviço (daemon)" +msgstr "Como um daemon" #. Type: select #. Choices #: ../ddclient.templates:16001 -#| msgid "Run ddclient on PPP connect?" msgid "On PPP connect" -msgstr "Ao ligar por PPP" +msgstr "Em ligação PPP" #. Type: select #. Description #: ../ddclient.templates:16002 msgid "How to run ddclient:" -msgstr "Como executar o ddclient:" +msgstr "Como correr o ddclient:" #. Type: select #. Description #: ../ddclient.templates:16002 msgid "The ddclient run mode. Your options:" -msgstr "Modo de execução do ddclient. Opções:" +msgstr "O modo de execução do ddclient. As suas opções:" #. Type: select #. Description #: ../ddclient.templates:16002 msgid "" -"As a daemon: ddclient runs in the background periodically checking to -see if " +"As a daemon: ddclient runs in the background periodically checking to see if " "the IP address has changed." msgstr "" -"Como serviço (deamon): o ddclient é executado em segundo plano, verificando " -"periodicamente se o endereço IP mudou." +"Como um daemon: ddclient corre em segundo plano verificando periodicamente " +"para ver se o seu endereço IP mudou." #. Type: select #. Description @@ -361,42 +323,32 @@ "On PPP connect: Each time you connect via PPP ddclient will start, update " "the IP address, and exit." msgstr "" -"Ao ligar por PPP: de cada vez que for feita uma ligação via PPP, o ddclient vai " -"iniciar, actualizar o endereço IP e sair." +"Em ligação PPP: Cada vez que você liga via PPP o ddclient irá arrancar, " +"actualiza o endereço IP, e termina." #. Type: string #. Description #: ../ddclient.templates:17001 msgid "Time between address checks:" -msgstr "Intervalo entre verificações de endereço:" +msgstr "Tempo entre verificações de endereço:" #. Type: string #. Description #: ../ddclient.templates:17001 -#| msgid "" -#| "Please choose the delay between interface address checks. Values may -be " -#| "given in seconds (e.g. \"5s\"), in minutes (e.g. \"3m\"), in hours -(e.g. " -#| "\"7h\") or in days (e.g. \"1d\")." -msgid "" -"How long ddclient should wait between IP address checks. Values may be -given " -"in seconds (e.g., \"300s\"), in minutes (e.g., \"5m\"), in hours (e.g., -\"7h" +msgid "" +"How long ddclient should wait between IP address checks. Values may be given " +"in seconds (e.g., \"300s\"), in minutes (e.g., \"5m\"), in hours (e.g., \"7h" "\") or in days (e.g., \"1d\")." msgstr "" -"Intervalo entre verificações de endereço IP. Os valores podem ser " -"dados -em segundos (p. ex., \"300s\"), em minutos (p. ex., \"5m\"), em horas " -"(p. ex., \"7h" -"\") ou em dias (p. ex., \"1d\")." +"Quando tempo deve o ddclient esperar entre verificações de endereço IP. " +"Valores podem ser dados em segundo (ex. \"300s\"), em minutos (ex. \"5m\"), " +"em horas (ex, \"7h\") ou em dias (ex. \"1d\")." #. Type: select #. Choices #: ../ddclient.templates:18001 msgid "From list" -msgstr "Da lista" +msgstr "A partir de lista" #. Type: select #. Choices @@ -408,58 +360,56 @@ #. Description #: ../ddclient.templates:18002 msgid "How to enter host names:" -msgstr "Como introduzir nomes de hospedeiro:" +msgstr "Como inserir nomes de máquinas:" #. Type: select #. Description #: ../ddclient.templates:18002 msgid "How to prompt you for the host name(s) that ddclient will update." -msgstr "Como solicitar o(s) nome(s) de hospedeiro a actualizar." +msgstr "" +"Como lhe perguntar pelos nome(s) de máquina(s) que o ddclient irá actualizar." #. Type: select #. Description #: ../ddclient.templates:18002 msgid "" -"If you choose \"From list\", this program will attempt to look up the -host " +"If you choose \"From list\", this program will attempt to look up the host " "names that are registered with your DynDNS account. You will then select " "hosts from that list." msgstr "" -"Escolhendo \"Da lista\", o programa procurará os nomes -de " -"hospedeiro registados na conta DynDNS. Terão que ser seleccionados " -"hospedeiros dessa lista." +"Se você escolher \"A partir de lista\", este programa irá tentar encontrar " +"os nomes de máquinas que estão registados com a sua conta DynDNS. Você " +"irá então selecionar máquinas dessa lista." #. Type: select #. Description #: ../ddclient.templates:18002 -msgid "If you choose \"Manually\", you will have to type in the host -name(s)." -msgstr "Escolhendo \"Manualmente\", terão que ser introduzidos os nomes de hospedeiro." +msgid "If you choose \"Manually\", you will have to type in the host name(s)." +msgstr "" +"Se você escolher \"Manualmente\", você terá de escrever os nomes das" +" máquina(s)." #. Type: multiselect #. Description #: ../ddclient.templates:19001 -#| msgid "Host names to keep updated:" msgid "Hosts to update:" -msgstr "Hospedeiros a actualizar:" +msgstr "Máquinas para actualizar:" #. Type: multiselect #. Description #: ../ddclient.templates:19001 msgid "" -"The host name(s) to keep updated with your current IP address. (This -list of " +"The host name(s) to keep updated with your current IP address. (This list of " "host names was downloaded from your DynDNS account.)" msgstr "" -"Nome(s) de hospedeiro a manter actualizado(s) com o endereço IP em " -"uso. (Esta lista de hospedeiros foi transferida da conta DynDNS)." +"Os nome(s) de máquinas para manter actualizadas com o seu endereço IP actual. " +"(Esta lista de nomes de máquinas foi descarregada da sua conta DynDNS.)" #. Type: error #. Description #: ../ddclient.templates:20001 msgid "Empty host list" -msgstr "Lista de hospedeiros vazia" +msgstr "Lista de máquinas vazia" #. Type: error #. Description @@ -468,8 +418,8 @@ "The list of host names managed under your account is empty when retrieved " "from the dynamic DNS service website." msgstr "" -"Quando obtida do sítio web do serviço de DNS dinâmico, " -"a lista de hospedeiros estará vazia." +"A lista de nomes de máquinas geridas sob a sua conta estava vazia quando " +"obtida a partir do sítio web do serviço de DNS dinâmico." #. Type: error #. Description @@ -478,181 +428,17 @@ "You may have provided an incorrect username or password, or the online " "account may have no host names configured." msgstr "" -"O nome de utilizador ou a senha podem ter sido incorretamente introduzidos, -ou a conta pode não ter os nomes de hospedeiro configurados." +"Você pode ter fornecido um nome de utilizador ou palavra passe incorretos, " +"ou a conta online pode não ter nomes de máquinas configurados." #. Type: error #. Description #: ../ddclient.templates:20001 msgid "" "Please check your account to be sure you have host names configured, then " -"run \"dpkg-reconfigure ddclient\" to input your username and password -again." +"run \"dpkg-reconfigure ddclient\" to input your username and password again." msgstr "" -"Confirmar que tem nomes de hospedeiro configurados na conta; de seguida " -"executar \"dpkg-reconfigure ddclient\" para introduzir novamente -o utilizador e a senha." - -#, fuzzy -#~| msgid "" -#~| "You should enable this option if ddclient should be run every time -a PPP " -#~| "connection is established. Note: This mode is not compatible with -daemon " -#~| "mode." -#~ msgid "" -#~ "Whether ddclient should run every time a PPP connection is -established. " -#~ "Note: ddclient will not run as a daemon if this is enabled." -#~ msgstr "" -#~ "No caso de o ddclient dever ser executado de cada vez -que uma ligação PPP for estabelecida. " -#~ "Nota: O ddclient não será executado no modo de serviço (daemon) " -#~ "se esta opção for activada." - -#~ msgid "Find public IP using checkip.dyndns.com?" -#~ msgstr "Procurar IP público usando checkip.dyndns.com?" - -#, fuzzy -#~| msgid "" -#~| "Please choose whether ddclient should try to find the IP address of -this " -#~| "machine via the DynDNS web interface. This is recommended for -machines " -#~| "that are using Network Address Translation." -#~ msgid "" -#~ "Whether ddclient should try to find the IP address of this machine via " -#~ "the DynDNS web interface. This is recommended for machines that are -using " -#~ "Network Address Translation." -#~ msgstr "" -#~ "No caso de o ddclient dever tentar procurar o endereço IP desta máquina através -da interface " -#~ "web DynDNS. Recomendado para máquinas que estiverem usando " -#~ "Network Address Translation." - -#~ msgid "Run ddclient as daemon?" -#~ msgstr "Executar o ddclient como serviço?" - -#, fuzzy -#~| msgid "" -#~| "Please choose whether you want ddclient to be run in daemon mode on " -#~| "system startup." -#~ msgid "Whether ddclient should run in daemon mode on system startup." -#~ msgstr "" -#~ "No caso de o ddclient dever ser executado em modo de serviço (daemon) " -#~ "no arranque do sistema." - -#~ msgid "" -#~ "The list of host names managed via your DynDNS account has been " -#~ "downloaded. Please choose the one(s) for which ddclient should be -used to " -#~ "keep IP address records up to date." -#~ msgstr "" -#~ "A lista de nomes de hospedeiro geridas pela conta DynDNS foi " -#~ "trasferida. Escolher o(s) nome(s) para os quais deve ser usado " -#~ "o ddclient para manter os registos de endereços IP actualizados." - -#~ msgid "Selection method for updated names:" -#~ msgstr "Método de selecção para nomes actualizados:" - -#~ msgid "" -#~ "You'll have to select which host names to update using ddclient. -You can " -#~ "select host names to update from a list (taken from your DynDNS -account) " -#~ "or enter them manually." -#~ msgstr "" -#~ "Terão que ser seleccionados os nomes de hospedeiro a actualizar " -#~ "usando o ddclient. " -#~ "Os nomes podem ser seleccionados de uma lista (obtidos da conta DynDNS) " -#~ "ou introduzidos manualmente." - -#~ msgid "Interval between ddclient runs:" -#~ msgstr "Intervalo entre execuções do ddclient:" - -#~ msgid "Network interface used for dynamic DNS service:" -#~ msgstr "Interface de rede usada para o serviço de DNS dinâmico:" - -#~ msgid "" -#~ "Please enter the name of the network interface (eth0/wlan0/ppp0/...) -to " -#~ "use for dynamic DNS service." -#~ msgstr "" -#~ "Introduzir o nome da interface de rede (eth0/wlan0/ppp0/...) a -usar " -#~ "para o serviço de DNS dinâmico." - -#~ msgid "Password for dynamic DNS service:" -#~ msgstr "Senha para o serviço de DNS dinâmico:" - -#~ msgid "Username for dynamic DNS service:" -#~ msgstr "Utilizador para o serviço de DNS dinâmico:" - -#~ msgid "DynDNS fully qualified domain names:" -#~ msgstr "Nomes de domínio DynDNS totalmente qualificados (FQDN):" - -#, fuzzy -#~| msgid "Run ddclient on PPP connect?" -#~ msgid "Run ddclient on DHCP update?" -#~ msgstr "Executar o ddclient na actualização DHCP?" - -#, fuzzy -#~| msgid "" -#~| "You should enable this option if ddclient should be run every time -a PPP " -#~| "connection is established. Note: This mode is not compatible with -daemon " -#~| "mode." -#~ msgid "" -#~ "You should enable this option if ddclient should be run every time -the IP " -#~ "address is changed by the DHCP client (dhclient). Note: This mode is -not " -#~ "compatible with daemon mode." -#~ msgstr "" -#~ "Activar esta opção para executar o ddclient de cada vez -que " -#~ "uma ligação PPP for estabelecida. Nota: Este modo não é compatível -com o " -#~ "modo de serviço (daemon)." - -#~ msgid "Modified configuration file" -#~ msgstr "Ficheiro de configuração modificado" - -#~ msgid "" -#~ "The config file /etc/ddclient.conf on your system does not consist of " -#~ "three entries. The automatic configuration utility cannot handle this " -#~ "situation." -#~ msgstr "" -#~ "O ficheiro de configuração /etc/ddclient.conf no sistema não -consiste " -#~ "de três entradas. O utilitário de configuração automática não consegue -lidar " -#~ "com isso." - -#~ msgid "" -#~ "If you have edited the configuration file manually, it won't be -modified. " -#~ "If you need a new configuration file, run \"dpkg-reconfigure -ddclient\"." -#~ msgstr "" -#~ "Se o ficheiro de configuração foi editado manualmente, ele não será " -#~ "modificado. Se for necessário um novo ficheiro de configuração, -executar " -#~ "\"dpkg-reconfigure ddclient\"." - -#~ msgid "www.dyndns.com " -#~ msgstr "www.dyndns.com " - -#~ msgid "www.easydns.com " -#~ msgstr "www.easydns.com " - -#~ msgid "www.dslreports.com " -#~ msgstr "www.dslreports.com " - -#~ msgid "www.zoneedit.com " -#~ msgstr "www.zoneedit.com " +"Por favor verifique a sua conta para certificar que tem nomes de máquinas " +"configurados, depois corra \"dpkg-reconfigure ddclient\" para inserir o seu " +"nome de utilizador e palavra passe outra vez." -#~ msgid "ddclient update interval:" -#~ msgstr "Intervalo de actualização do ddclient:" diff -Nru ddclient-3.9.1/debian/postinst ddclient-3.10.0/debian/postinst --- ddclient-3.9.1/debian/postinst 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/postinst 2023-01-16 02:47:24.000000000 +0000 @@ -122,8 +122,19 @@ # generated had those options not been passed. case $1 in configure|abort-upgrade|abort-deconfigure|abort-remove) - #### Begin 1st part generated by dh_installsystemd/13.1 - # This will only remove masks created by d-s-h on package removal. + #### Begin part generated by dh_installinit/13.11.1 + if [ -z "${DPKG_ROOT:-}" ] && [ -x "/etc/init.d/ddclient" ]; then + update-rc.d ddclient defaults >/dev/null + if [ -n "$2" ]; then + _dh_action=restart + else + _dh_action=start + fi + invoke-rc.d --skip-systemd-native ddclient $_dh_action || exit 1 + fi + #### End part generated by dh_installinit/13.11.1 + #### Begin 1st part generated by dh_installsystemd/13.11.1 + # The following line should be removed in trixie or trixie+1 deb-systemd-helper unmask 'ddclient.service' >/dev/null || true # was-enabled defaults to true, so new installations run enable. @@ -136,19 +147,18 @@ # cleaned up on purge. Also remove old symlinks. deb-systemd-helper update-state 'ddclient.service' >/dev/null || true fi - #### End 1st part generated by dh_installsystemd/13.1 - #### Begin 2nd part generated by dh_installsystemd/13.1 + #### End 1st part generated by dh_installsystemd/13.11.1 + #### Begin 2nd part generated by dh_installsystemd/13.11.1 if [ -d /run/systemd/system ]; then systemctl --system daemon-reload >/dev/null || true - deb-systemd-invoke start 'ddclient.service' >/dev/null || true - fi - #### End 2nd part generated by dh_installsystemd/13.1 - #### Begin part generated by dh_installinit/13.1 - if [ -x "/etc/init.d/ddclient" ]; then - update-rc.d ddclient defaults >/dev/null - invoke-rc.d ddclient start || exit 1 + if [ -n "$2" ]; then + _dh_action=restart + else + _dh_action=start + fi + deb-systemd-invoke $_dh_action 'ddclient.service' >/dev/null || true fi - #### End part generated by dh_installinit/13.1 + #### End 2nd part generated by dh_installsystemd/13.11.1 ;; esac else diff -Nru ddclient-3.9.1/debian/prerm ddclient-3.10.0/debian/prerm --- ddclient-3.9.1/debian/prerm 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/prerm 2023-01-16 02:47:24.000000000 +0000 @@ -14,15 +14,15 @@ # to make it possible to conditionally enable the service. The # --no-start option also disables stopping the service on remove, so # it has to be manually stopped here. -#### Begin part generated by dh_installsystemd/13.1 -if [ -d /run/systemd/system ]; then +#### Begin part generated by dh_installsystemd/13.11.1 +if [ -z "${DPKG_ROOT:-}" ] && [ "$1" = remove ] && [ -d /run/systemd/system ] ; then deb-systemd-invoke stop 'ddclient.service' >/dev/null || true fi -#### End part generated by dh_installsystemd/13.1 -#### Begin part generated by dh_installinit/13.1 -if [ -x "/etc/init.d/ddclient" ]; then - invoke-rc.d ddclient stop || exit 1 +#### End part generated by dh_installsystemd/13.11.1 +#### Begin part generated by dh_installinit/13.11.1 +if [ -z "${DPKG_ROOT:-}" ] && [ "$1" = remove ] && [ -x "/etc/init.d/ddclient" ] ; then + invoke-rc.d --skip-systemd-native ddclient stop || exit 1 fi -#### End part generated by dh_installinit/13.1 +#### End part generated by dh_installinit/13.11.1 exit 0 diff -Nru ddclient-3.9.1/debian/rules ddclient-3.10.0/debian/rules --- ddclient-3.9.1/debian/rules 2020-09-08 18:24:00.000000000 +0000 +++ ddclient-3.10.0/debian/rules 2023-01-16 02:47:24.000000000 +0000 @@ -2,6 +2,22 @@ %: dh $@ +# postinst generates /etc/ddclient.conf via debconf. Move the default +# /etc/ddclient.conf to the examples directory to prevent it from interfering. +# +# TODO: It seems like it should be possible to use dh_install to move the file, +# but I couldn't figure out how to make it work. Adding the following line to +# debian/ddclient.install copies the file rather than renames it (as of +# debhelper 13): +# +# debian/ddclient/etc/ddclient.conf => /usr/share/doc/ddclient/examples/sample-etc_ddclient.conf +# +# dh_installexamples similarly copies the file (and it doesn't provide a way to +# rename it). +execute_after_dh_auto_install: + install -d debian/ddclient/usr/share/doc/ddclient/examples + mv debian/ddclient/etc/ddclient.conf debian/ddclient/usr/share/doc/ddclient/examples/sample-etc_ddclient.conf + # This package conditionally enables the ddclient service based on # debconf answers. # diff -Nru ddclient-3.9.1/docs/ipv6-design-doc.md ddclient-3.10.0/docs/ipv6-design-doc.md --- ddclient-3.9.1/docs/ipv6-design-doc.md 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/docs/ipv6-design-doc.md 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,337 @@ +# Design Doc: IPv6 Support + +Author: [@rhansen](https://github.com/rhansen/)\ +Date: 2020-06-09\ +Signed off by: +[@SuperSandro2000](https://github.com/SuperSandro2000/) + +## Objective + +Add full IPv6 support to ddclient, including support for dual-stack +systems. + +## Background + +ddclient's current IPv6 support is limited: + + * Users can update either an IPv6 record or an IPv4 record for a + host, not both. + * If SSL is used for an HTTP request, IPv6 will be used if the + remote host has a AAAA record, even if the user would rather use + IPv4. This breaks `use=web` for IPv4 if the `web` URL's host has a + AAAA record. + * The `use=if` method only works if the user sets `if-skip` to + something that skips over all IPv4 addresses in the output of + `ifconfig` (or `ip`). If the output contains an IPv4 address after + the IPv6 address then `use=if` cannot be used for IPv6. + * There is no support for falling back to IPv4 if an IPv6 connection + fails. + * `use=if` does not filter out locally scoped or temporary IPv6 + addresses. + +Some attempts have been made to add more robust IPv6 support: + + * Debian's ddclient package applies a + [patch](https://salsa.debian.org/debian/ddclient/-/blob/67a138aa3d98d70f01766123f58ef40e98693fd4/debian/patches/usev6.diff) + that adds a new `usev6` option. The `usev6` option can be set to + `ip` or `if`, but not any of the other strategies currently + available for the `use` option (`web`, `cmd`, `fw`, `cisco`, + `cisco-asa`). When set to `ip` or `if`, only IPv6 addresses are + considered; IPv4 addresses are ignored. The patch does not change + the behavior of the `use` option, so `use=web` or `use=cmd` can be + used for IPv6 if pointed at something that only outputs an IPv6 + address. + * [ddclient-curl](https://github.com/astlinux-project/ddclient-curl) + is a fork of ddclient that uses curl as the HTTP client (instead + of ddclient's own homemade client) for more robust IPv6 support. + * PR #40 is perhaps the most comprehensive attempt at adding full + IPv6 support, but it was never merged and has since + bit-rotted. There is renewed effort to rebase the changes and get + them merged in. PR #40 adds new options and changes some existing + options. The approach taken is to completely isolate IPv4 address + detection from IPv6 address detection and require the update + protocol callbacks to handle each type of address appropriately. + +## Requirements + + * The mechanism for determining the current IPv4 address (the `use` + option) must be independently configurable from the mechanism used + to determine the current IPv6 address. + * The user must be able to disable IPv4 address updates without + affecting IPv6 updates. + * The user must be able to disable IPv6 address updates without + affecting IPv4 updates. + * If HTTP polling is used for both IPv4 and IPv6 address discovery, + the URL used to determine the IPv4 address (the `web` option) must + be independently configurable from the URL used to determine the + IPv6 address. + * The use of IPv4 or IPv6 to update a record must be independent of + the type of record being updated (IPv4 or IPv6). + * The callback for the update protocol must be given both addresses, + even if only one of the two addresses has changed. + * The callback for the update protocol must be told which addresses + have changed. + * There must be IPv6 equivalents to `use=ip`, `use=if`, `use=web`, + and `use=cmd`. For the IPv6 equivalent to `use=if`, it is + acceptable to ignore non-global and temporary addresses (the user + can always use the IPv6 equivalent to `use=cmd` to get non-global + or temporary addresses). + * Existing support for updating IPv6 records must not be lost. + * Some dynamic DNS service providers use separate credentials for + the IPv4 and IPv6 records. These providers must be supported, + either by accepting both sets of credentials in a single host's + configuration or by allowing the user to specify the same host + twice, once for IPv4 and once for IPv6. + +### Nice-to-Haves + + * The user should be able to force the update protocol to use IPv4 + or IPv6. + * Unless configured otherwise, ddclient should first attempt to + update via IPv6 and fall back to IPv4 if the IPv6 connection + fails. This behavior can be added later; for now it is acceptable + to keep the current behavior (use IPv6 without IPv4 fallback if + there is a AAAA record, use IPv4 if there is no AAAA record). + * Full backwards compatibility with existing config files and + flags. The trade-offs between migration burden, long-term + usability, and code maintenance should be carefully considered. + * IPv6 equivalents to `use=fw`, `use=cisco`, and `use=cisco-asa`. + * Add IPv6 support in protocol callbacks where IPv6 support is + currently missing. (This can be done later.) + +## Proposal + +### Configuration changes + + * Add new `usev4` and `usev6` settings that are like the current + `use` setting except they only apply to IPv4 and IPv6, + respectively. + * `usev4` can be set to one of the following values: `disabled`, + `ipv4`, `webv4`, `fwv4`, `ifv4`, `cmdv4`, `ciscov4`, + `cisco-asav4` + * `usev6` can be set to one of the following values: `disabled`, + `ipv6`, `webv6`, `fwv6`, `ifv6`, `cmdv6`, `ciscov6`, + `cisco-asav6` + * Add a new `use` strategy: `disabled`. + * The `disabled` value for `use`, `usev4`, and `usev6` causes + ddclient to act as if it was never set. This is useful for + overriding the global value for a particular host. + * For compatibility with ddclient-curl, `no` is a deprecated alias + of `disabled`. + * Add new `ipv4`, `ipv6`, `webv4`, `webv4-skip`, `webv6`, + `webv6-skip`, `ifv4`, `ifv6`, `cmdv4`, `cmdv6`, etc. settings that + behave like their versionless counterparts except they only apply + to IPv4 or IPv6. Deprecate the versionless counterparts, and + change their behavior so that they also influence the default + value of the versioned options. (Example: Suppose + `usev4=ifv4`. If `ifv4` is not set then `if` is used.) Special + notes: + * The value of `ip` will only serve as the default for `ipv4` + (or `ipv6`) if it contains an IPv4 (or IPv6) address. + * There is currently an `ipv6` boolean setting. To preserve + backward compatibility with existing configs, `ipv6` set to a + boolean value is ignored (other than a warning). + * There is no `ifv4-skip` or `ifv6-skip` because it's ddclient's + responsibility to properly parse the output of whatever tool + it uses to read the interface's addresses. + * For now there is no `cmdv4-skip` or `cmdv6-skip`. Anyone who + already knows how to write a regular expression can probably + write a wrapper script. These may be added in the future if + users request them, especially if it facilitates migration + away from the deprecated `cmd-skip` setting. + * For `usev6=ifv6`, interfaces are likely to have several IPv6 + addresses (unlike IPv4). Choosing the "right" IPv6 address is + not trivial. Fortunately, we don't have to solve this + perfectly right now; we can choose something that mostly + works and let user bug reports guide future refinements. For + the first iteration, we will try the following: + * Ignore addresses that are not global unicast. + (Unfortunately, the `ip` command from iproute2 does not + provide a way to filter out ULA addresses so we will have + to do this ourselves.) + * Ignore temporary addresses. + * If no addresses remain, log a warning and don't update the + IPv6 record. + * Otherwise, if one of the remaining addresses matches the + previously selected address, continue to use it. + * Otherwise, select one arbitrarily. + * Deprecate the `use` setting (print a loud warning) but keep its + existing semantics with an exception: If there is a conflict with + `usev4` or `usev6` then those take priority: + * If `use`, `usev4`, and `usev6` are all set then a warning is + logged and the `use` setting is ignored. + * If `use` and `usev4` are both set and the `use` strategy + discovers an IPv4 address that differs from the address + discovered by the `usev4` strategy, then the address from + `usev4` is used and a warning is logged. + * If `use` and `usev6` are both set and the `use` strategy + discovers an IPv6 address that differs from the address + discovered by the `usev6` strategy, then the address from + `usev6` is used and a warning is logged. + * If `usev4` (`usev6`) is not set: + * If `ipv4` (`usev6`) is set, ddclient acts as if `usev4` + (`usev6`) was set to `ipv4` (`ipv6`). + * Otherwise, if `ifv4` (`ifv6`) is set, ddclient acts as if + `usev4` (`usev6`) was set to `ifv4` (`ifv6`). + * Otherwise, if `cmdv4` (`cmdv6`) is set, ddclient acts as if + `usev4` (`usev6`) was set to `cmdv4` (`cmdv6`). + * Otherwise, if `fwv4` (`fwv6`) is set, ddclient acts as if + `usev4` (`usev6`) was set to `fwv4` (`fwv6`). + * Otherwise, `usev4` (`usev6`) remains unset. + * To support separate credentials for IPv4 vs. IPv6 updates, users + can specify the same host multiple times, each time with different + options. + +### Internal API changes + + * Add two new entries to the `$config{$host}` hash: + * `$config{$host}{'wantipv4'}` is set to: + * If `usev4` is enabled, the IPv4 address discovered by the + `usev4` strategy. + * Otherwise, if `use` is enabled and the `use` strategy + discovered an IPv4 address, the IPv4 address discovered by + the `use` strategy. + * Otherwise, `undef`. + * `$config{$host}{'wantipv6'}` is set to: + * If `usev6` is enabled, the IPv6 address discovered by the + `usev6` strategy. + * Otherwise, if `use` is enabled and the `use` strategy + discovered an IPv6 address, the IPv6 address discovered by + the `use` strategy. + * Otherwise, `undef`. + * Deprecate the existing `$config{$host}{'wantip'}` entry, to be + removed after all update protocol callbacks have been updated to + use the above new entries. In the meantime, this entry's value + depends on which of `use`, `usev4`, and `usev6` is enabled, and + what type of IP address is discovered by the `use` strategy (if + enabled), according to the following table: + + | `use` | `usev4` | `usev6` | resulting value | + | :---: | :---: | :---: | :--- | + | ✔(IPv4) | ✖ | ✖ | the IPv4 address discovered by the `use` strategy | + | ✔(IPv6) | ✖ | ✖ | the IPv6 address discovered by the `use` strategy | + | ✖ | ✔ | ✖ | the IPv4 address discovered by the `usev4` strategy | + | ✖ | ✖ | ✔ | the IPv6 address discovered by the `usev6` strategy | + | ✔(IPv4) | ✔ | ✖ | the IPv4 address discovered by the `usev4` strategy (and log another warning if it doesn't match the IPv4 address found by the `use` strategy) | + | ✔(IPv6) | ✔ | ✖ | the IPv6 address discovered by the `use` strategy | + | ✔(IPv4) | ✖ | ✔ | the IPv4 address discovered by the `use` strategy | + | ✔(IPv6) | ✖ | ✔ | the IPv6 address discovered by the `usev6` strategy (and log another warning if it doesn't match the IPv6 address found by the `use` strategy) | + + * To support separate credentials for IPv4 vs. IPv6 updates, convert + the `%config` hash of host configs into a list of host configs. A + second definition for the same host adds a second entry rather + than overwrites the existing entry. + +## Alternatives Considered + +### Repurpose the existing settings for v4 + +Rather than create new `usev4`, `ifv4`, `cmdv4`, etc. settings, +repurpose the existing `use`, `if`, `cmd`, etc. settings for IPv4. + +Why this was rejected: + * There is a usability advantage to the symmetry with the `v6` + settings. + * It is easier to remain compatible with existing configurations. + +### Let `use` set the default for `usev4` + +Rather than three separate IP discovery mechanisms (`use`, `usev4`, +and `usev6`), have just two (`usev4` and `usev6`) and let the old +`use` setting control the default for `usev4`: If `usev4` is not set, +then `use=foo` is equivalent to `usev4=foov4`. + +Why this was rejected: Backwards incompatibility. Specifically, +configurations that previously updated an IPv6 record would instead +(attempt to) update an IPv4 record. + +### Let `use` set the default for `usev4` and `usev6` + +Rather than three separate IP discovery mechanisms (`use`, `usev4`, +and `usev6`), have just two (`usev4` and `usev6`) and let the old +`use` setting control the default for `usev4` and `usev6`: + + * If neither `usev4` nor `usev6` is set, then `use=foo` is + equivalent to `usev4=foov4,usev6=foov6`. + * If `usev4` is set but not `usev6`, then `use=foo` is equivalent to + `usev6=foov6`. + * If `usev6` is set but not `usev4`, then `use=foo` is equivalent to + `usev4=foov4`. + * If both `usev4` and `usev6` are set, then `use=foo` is ignored. + +Why this was rejected: The new design would cause existing +configurations to trigger surprising, and possibly undesired (e.g., +timeouts or update errors), new behavior: + + * Configurations that previously updated only an IPv4 record would + also update an IPv6 record. + * Similarly, configurations that previously updated only an IPv6 + record would also update an IPv4 record. + +### Replace uses of `'wantip'` with `'wantipv4'` + +Rather than support `'wantip'`, `'wantipv4'`, and `'wantipv6'`, just +replace all `'wantip'` references to `'wantipv4'`. + +Why this was rejected: This would break compatibility for users that +are currently updating IPv6 addresses. (Compatibility would be +restored once the update protocol callbacks are updated to honor +`'wantipv6'`.) + +### Single `if` setting for both `usev4=if` and `usev6=if` + +The proposed design calls for separate `ifv4` and `ifv6` settings. If +the user sets `usev4=if,usev6=if`, then the user most likely wants to +use the same interface for both IPv4 and IPv6. Rather than create +separate `ifv4` and `ifv6` settings, have a single `if` setting used +for both `usev4` and `usev6`. + +Why this was rejected: + * Separate `v4` and `v6` settings adds consistency to the + configuration. + * There are cases where a user will want to use a different + interface. In particular, an IPv6 over IPv4 tunnel (e.g., + https://tunnelbroker.net) involves creating a separate interface + that is used only for IPv6. + +### Separate IPv4 and IPv6 credentials + +In order to support providers that use separate credentials for IPv4 +and IPv6 updates, the proposed design allows the user to define the +same host twice. We could instead add additional options so that the +user can provide both sets of credentials in a single host definition. + +Why this was rejected: + * The proposed design is easier to implement, as it does not require + any modifications to existing protocol implementations. + * The proposed design is less likely to cause problems for users + that rely on globals instead of host-specific options. For + example, a configuration file like the following might not do what + the user expects: + + ``` + ssl=true, use=if, if=eth0 + + protocol=foo + login=username-for-ipv4 + password=password-for-ipv4 + loginv6=username-for-ipv6 + passwordv6=password-for-ipv6 + myhost.example.com + + protocol=bar + login=username + password=password + # This host definition will use loginv6, passwordv6 from above + # because the user didn't end each setting with a line + # continuation: + my-other-host.example.com + ``` + + * The proposed design provides some bonus functionality: + * Users can smoothly transition between different providers by + updating both providers simultaneously until the domain + registration switches to the new registrar. + * Users can take advantage of providers that support multiple A + or multiple AAAA records for the same hostname, assuming each + record has independent credentials. diff -Nru ddclient-3.9.1/.envrc ddclient-3.10.0/.envrc --- ddclient-3.9.1/.envrc 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/.envrc 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,5 @@ +if has lorri; then + eval "$(lorri direnv)" +else + use nix +fi diff -Nru ddclient-3.9.1/.github/workflows/ci.yml ddclient-3.10.0/.github/workflows/ci.yml --- ddclient-3.9.1/.github/workflows/ci.yml 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/.github/workflows/ci.yml 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,151 @@ +name: CI +on: + push: + pull_request: + +jobs: + test-debian-like: + strategy: + matrix: + image: + - ubuntu:latest + - ubuntu:16.04 + - debian:testing + - debian:stable + - debian:oldstable + runs-on: ubuntu-latest + container: + image: ${{ matrix.image }} + steps: + - name: install dependencies + run: | + apt-get update && + DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends \ + automake \ + ca-certificates \ + git \ + libhttp-daemon-perl \ + libhttp-daemon-ssl-perl \ + libio-socket-inet6-perl \ + libio-socket-ip-perl \ + libplack-perl \ + libtest-mockmodule-perl \ + libtest-tcp-perl \ + libtest-warnings-perl \ + liburi-perl \ + net-tools \ + make \ + ; + - uses: actions/checkout@v2 + - name: autogen + run: ./autogen + - name: configure + run: ./configure + - name: check + run: make VERBOSE=1 AM_COLOR_TESTS=always check + - name: distcheck + run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck + - name: distribution tarball is complete + run: ./.github/workflows/scripts/dist-tarball-check + + #test-centos6: + # runs-on: ubuntu-latest + # container: centos:6 + # steps: + # - uses: actions/checkout@v1 + # - name: install dependencies + # run: | + # yum install -y \ + # automake \ + # perl-IO-Socket-INET6 \ + # perl-core \ + # perl-libwww-perl \ + # ; + # - name: autogen + # run: ./autogen + # - name: configure + # run: ./configure + # - name: check + # run: make VERBOSE=1 AM_COLOR_TESTS=always check + # - name: distcheck + # run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck + + #test-centos8: + # runs-on: ubuntu-latest + # container: centos:8 + # steps: + # - uses: actions/checkout@v2 + # - name: install dependencies + # run: | + # dnf --refresh --enablerepo=PowerTools install -y \ + # automake \ + # make \ + # perl-HTTP-Daemon \ + # perl-IO-Socket-INET6 \ + # perl-Test-Warnings \ + # perl-core \ + # ; + # - name: autogen + # run: ./autogen + # - name: configure + # run: ./configure + # - name: check + # run: make VERBOSE=1 AM_COLOR_TESTS=always check + # - name: distcheck + # run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck + + test-fedora: + runs-on: ubuntu-latest + container: fedora + steps: + - uses: actions/checkout@v2 + - name: install dependencies + run: | + dnf --refresh install -y \ + automake \ + findutils \ + make \ + perl \ + perl-HTTP-Daemon \ + perl-HTTP-Daemon-SSL \ + perl-IO-Socket-INET6 \ + perl-Plack \ + perl-Test-MockModule \ + perl-Test-TCP \ + perl-Test-Warnings \ + net-tools \ + ; + - name: autogen + run: ./autogen + - name: configure + run: ./configure + - name: check + run: make VERBOSE=1 AM_COLOR_TESTS=always check + - name: distcheck + run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck + + test-redhat-ubi7: + runs-on: ubuntu-latest + # we use redhats univeral base image which is not available on docker hub + # https://catalog.redhat.com/software/containers/ubi7/ubi/5c3592dcd70cc534b3a37814 + container: registry.access.redhat.com/ubi7/ubi + steps: + - uses: actions/checkout@v2 + - name: install dependencies + run: | + yum install -y \ + automake \ + make \ + perl-HTTP-Daemon \ + perl-IO-Socket-INET6 \ + perl-core \ + iproute \ + ; + - name: autogen + run: ./autogen + - name: configure + run: ./configure + - name: check + run: make VERBOSE=1 AM_COLOR_TESTS=always check + - name: distcheck + run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck diff -Nru ddclient-3.9.1/.github/workflows/scripts/dist-tarball-check ddclient-3.10.0/.github/workflows/scripts/dist-tarball-check --- ddclient-3.9.1/.github/workflows/scripts/dist-tarball-check 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/.github/workflows/scripts/dist-tarball-check 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,71 @@ +#!/bin/sh + +pecho() { printf %s\\n "$*"; } +log() { pecho "$@"; } +warning() { log "::warning::$@"; } +error() { log "::error::$@"; } +fatal() { error "$@"; exit 1; } +try() { "$@" || fatal "'$@' failed"; } + +# actions/checkout@v2 only makes a clone if Git is v2.18 or later, and this +# test requires a clone. +git_ver=$(try dpkg-query -f '${Version}' -W git) || exit 1 +dpkg --compare-versions "${git_ver}" ge '1:2.18~' || { + warning "This test requires Git v2.18 or later" + exit 0 +} + +dist_tarball=$(ls ddclient-*.tar.gz) \ + || fatal "'make dist' must be run before this test" + +tmpdir=$(try mktemp -d) || exit 1 +# newer git versions are particular about file ownership which can be ignored here +git config --global --add safe.directory /__w/ddclient/ddclient || true + +log "Copying contents of Git repository..." +try git archive --format=tar --prefix=git-repo/ HEAD \ + | try tar -C "${tmpdir}" -xv || exit 1 +( + try cd "${tmpdir}"/git-repo + # Delete files checked into Git that shouldn't be in the distribution + # tarball. + try rm -rf \ + .envrc \ + .github \ + .gitignore \ + docs/ipv6-design-doc.md \ + shell.nix \ + ; + # TODO: Delete this next line once support for Automake 1.11 is dropped and + # tap-driver.sh is removed from the Git repository. It is deleted here to + # avoid a spurious diff. + try rm -f build-aux/tap-driver.sh +) || exit 1 + +log "Extracting distribution tarball..." +try tar -C "${tmpdir}" -xvzf "${dist_tarball}" +try mv "${tmpdir}/${dist_tarball%.tar.gz}" "${tmpdir}"/dist-tarball +( + try cd "${tmpdir}"/dist-tarball + # Delete generated files + try rm -rf \ + Makefile.in \ + aclocal.m4 \ + build-aux/install-sh \ + build-aux/missing \ + build-aux/tap-driver.sh \ + configure \ + ; +) || exit 1 + +log "Comparing Git repository with distribution tarball..." +cd "${tmpdir}" +diff -qNr git-repo dist-tarball >/dev/null || { + error "Unexpected diff between the repo and the distribution tarball." + error "You may need to add a file to EXTRA_DIST in Makefile.am." + error "Diff output:" + diff -uNr git-repo dist-tarball \ + | while IFS= read -r line; do error "${line}"; done + exit 1 +} +log "No difference" diff -Nru ddclient-3.9.1/.gitignore ddclient-3.10.0/.gitignore --- ddclient-3.9.1/.gitignore 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/.gitignore 2022-10-20 18:06:35.000000000 +0000 @@ -3,3 +3,20 @@ .svn .cvsignore *~ +/Makefile +/Makefile.in +/aclocal.m4 +/autom4te.cache/ +/build-aux/install-sh +/build-aux/missing +/config.log +/config.status +/configure +/ddclient +/ddclient-*.tar.gz +/ddclient.conf +/t/*.log +/t/*.trs +/t/geturl_connectivity.pl +/t/version.pl +/test-suite.log diff -Nru ddclient-3.9.1/m4/ax_compare_version.m4 ddclient-3.10.0/m4/ax_compare_version.m4 --- ddclient-3.9.1/m4/ax_compare_version.m4 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/m4/ax_compare_version.m4 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,177 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_compare_version.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_COMPARE_VERSION(VERSION_A, OP, VERSION_B, [ACTION-IF-TRUE], [ACTION-IF-FALSE]) +# +# DESCRIPTION +# +# This macro compares two version strings. Due to the various number of +# minor-version numbers that can exist, and the fact that string +# comparisons are not compatible with numeric comparisons, this is not +# necessarily trivial to do in a autoconf script. This macro makes doing +# these comparisons easy. +# +# The six basic comparisons are available, as well as checking equality +# limited to a certain number of minor-version levels. +# +# The operator OP determines what type of comparison to do, and can be one +# of: +# +# eq - equal (test A == B) +# ne - not equal (test A != B) +# le - less than or equal (test A <= B) +# ge - greater than or equal (test A >= B) +# lt - less than (test A < B) +# gt - greater than (test A > B) +# +# Additionally, the eq and ne operator can have a number after it to limit +# the test to that number of minor versions. +# +# eq0 - equal up to the length of the shorter version +# ne0 - not equal up to the length of the shorter version +# eqN - equal up to N sub-version levels +# neN - not equal up to N sub-version levels +# +# When the condition is true, shell commands ACTION-IF-TRUE are run, +# otherwise shell commands ACTION-IF-FALSE are run. The environment +# variable 'ax_compare_version' is always set to either 'true' or 'false' +# as well. +# +# Examples: +# +# AX_COMPARE_VERSION([3.15.7],[lt],[3.15.8]) +# AX_COMPARE_VERSION([3.15],[lt],[3.15.8]) +# +# would both be true. +# +# AX_COMPARE_VERSION([3.15.7],[eq],[3.15.8]) +# AX_COMPARE_VERSION([3.15],[gt],[3.15.8]) +# +# would both be false. +# +# AX_COMPARE_VERSION([3.15.7],[eq2],[3.15.8]) +# +# would be true because it is only comparing two minor versions. +# +# AX_COMPARE_VERSION([3.15.7],[eq0],[3.15]) +# +# would be true because it is only comparing the lesser number of minor +# versions of the two values. +# +# Note: The characters that separate the version numbers do not matter. An +# empty string is the same as version 0. OP is evaluated by autoconf, not +# configure, so must be a string, not a variable. +# +# The author would like to acknowledge Guido Draheim whose advice about +# the m4_case and m4_ifvaln functions make this macro only include the +# portions necessary to perform the specific comparison specified by the +# OP argument in the final configure script. +# +# LICENSE +# +# Copyright (c) 2008 Tim Toolan +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice +# and this notice are preserved. This file is offered as-is, without any +# warranty. + +#serial 13 + +dnl ######################################################################### +AC_DEFUN([AX_COMPARE_VERSION], [ + AC_REQUIRE([AC_PROG_AWK]) + + # Used to indicate true or false condition + ax_compare_version=false + + # Convert the two version strings to be compared into a format that + # allows a simple string comparison. The end result is that a version + # string of the form 1.12.5-r617 will be converted to the form + # 0001001200050617. In other words, each number is zero padded to four + # digits, and non digits are removed. + AS_VAR_PUSHDEF([A],[ax_compare_version_A]) + A=`echo "$1" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \ + -e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \ + -e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \ + -e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \ + -e 's/[[^0-9]]//g'` + + AS_VAR_PUSHDEF([B],[ax_compare_version_B]) + B=`echo "$3" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \ + -e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \ + -e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \ + -e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \ + -e 's/[[^0-9]]//g'` + + dnl # In the case of le, ge, lt, and gt, the strings are sorted as necessary + dnl # then the first line is used to determine if the condition is true. + dnl # The sed right after the echo is to remove any indented white space. + m4_case(m4_tolower($2), + [lt],[ + ax_compare_version=`echo "x$A +x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/false/;s/x${B}/true/;1q"` + ], + [gt],[ + ax_compare_version=`echo "x$A +x$B" | sed 's/^ *//' | sort | sed "s/x${A}/false/;s/x${B}/true/;1q"` + ], + [le],[ + ax_compare_version=`echo "x$A +x$B" | sed 's/^ *//' | sort | sed "s/x${A}/true/;s/x${B}/false/;1q"` + ], + [ge],[ + ax_compare_version=`echo "x$A +x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/true/;s/x${B}/false/;1q"` + ],[ + dnl Split the operator from the subversion count if present. + m4_bmatch(m4_substr($2,2), + [0],[ + # A count of zero means use the length of the shorter version. + # Determine the number of characters in A and B. + ax_compare_version_len_A=`echo "$A" | $AWK '{print(length)}'` + ax_compare_version_len_B=`echo "$B" | $AWK '{print(length)}'` + + # Set A to no more than B's length and B to no more than A's length. + A=`echo "$A" | sed "s/\(.\{$ax_compare_version_len_B\}\).*/\1/"` + B=`echo "$B" | sed "s/\(.\{$ax_compare_version_len_A\}\).*/\1/"` + ], + [[0-9]+],[ + # A count greater than zero means use only that many subversions + A=`echo "$A" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"` + B=`echo "$B" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"` + ], + [.+],[ + AC_WARNING( + [invalid OP numeric parameter: $2]) + ],[]) + + # Pad zeros at end of numbers to make same length. + ax_compare_version_tmp_A="$A`echo $B | sed 's/./0/g'`" + B="$B`echo $A | sed 's/./0/g'`" + A="$ax_compare_version_tmp_A" + + # Check for equality or inequality as necessary. + m4_case(m4_tolower(m4_substr($2,0,2)), + [eq],[ + test "x$A" = "x$B" && ax_compare_version=true + ], + [ne],[ + test "x$A" != "x$B" && ax_compare_version=true + ],[ + AC_WARNING([invalid OP parameter: $2]) + ]) + ]) + + AS_VAR_POPDEF([A])dnl + AS_VAR_POPDEF([B])dnl + + dnl # Execute ACTION-IF-TRUE / ACTION-IF-FALSE. + if test "$ax_compare_version" = "true" ; then + m4_ifvaln([$4],[$4],[:])dnl + m4_ifvaln([$5],[else $5])dnl + fi +]) dnl AX_COMPARE_VERSION diff -Nru ddclient-3.9.1/m4/ax_prog_perl_modules.m4 ddclient-3.10.0/m4/ax_prog_perl_modules.m4 --- ddclient-3.9.1/m4/ax_prog_perl_modules.m4 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/m4/ax_prog_perl_modules.m4 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,77 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_prog_perl_modules.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_PROG_PERL_MODULES([MODULES], [ACTION-IF-TRUE], [ACTION-IF-FALSE]) +# +# DESCRIPTION +# +# Checks to see if the given perl modules are available. If true the shell +# commands in ACTION-IF-TRUE are executed. If not the shell commands in +# ACTION-IF-FALSE are run. Note if $PERL is not set (for example by +# calling AC_CHECK_PROG, or AC_PATH_PROG), AC_CHECK_PROG(PERL, perl, perl) +# will be run. +# +# MODULES is a space separated list of module names. To check for a +# minimum version of a module, append the version number to the module +# name, separated by an equals sign. +# +# Example: +# +# AX_PROG_PERL_MODULES( Text::Wrap Net::LDAP=1.0.3, , +# AC_MSG_WARN(Need some Perl modules) +# +# LICENSE +# +# Copyright (c) 2009 Dean Povey +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice +# and this notice are preserved. This file is offered as-is, without any +# warranty. + +#serial 8 + +AU_ALIAS([AC_PROG_PERL_MODULES], [AX_PROG_PERL_MODULES]) +AC_DEFUN([AX_PROG_PERL_MODULES],[dnl + +m4_define([ax_perl_modules]) +m4_foreach([ax_perl_module], m4_split(m4_normalize([$1])), + [ + m4_append([ax_perl_modules], + [']m4_bpatsubst(ax_perl_module,=,[ ])[' ]) + ]) + +# Make sure we have perl +if test -z "$PERL"; then +AC_CHECK_PROG(PERL,perl,perl) +fi + +if test "x$PERL" != x; then + ax_perl_modules_failed=0 + for ax_perl_module in ax_perl_modules; do + AC_MSG_CHECKING(for perl module $ax_perl_module) + + # Would be nice to log result here, but can't rely on autoconf internals + $PERL -e "use $ax_perl_module; exit" > /dev/null 2>&1 + if test $? -ne 0; then + AC_MSG_RESULT(no); + ax_perl_modules_failed=1 + else + AC_MSG_RESULT(ok); + fi + done + + # Run optional shell commands + if test "$ax_perl_modules_failed" = 0; then + : + $2 + else + : + $3 + fi +else + AC_MSG_WARN(could not find perl) +fi])dnl diff -Nru ddclient-3.9.1/m4/ax_prog_perl_version.m4 ddclient-3.10.0/m4/ax_prog_perl_version.m4 --- ddclient-3.9.1/m4/ax_prog_perl_version.m4 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/m4/ax_prog_perl_version.m4 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,70 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_prog_perl_version.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_PROG_PERL_VERSION([VERSION],[ACTION-IF-TRUE],[ACTION-IF-FALSE]) +# +# DESCRIPTION +# +# Makes sure that perl supports the version indicated. If true the shell +# commands in ACTION-IF-TRUE are executed. If not the shell commands in +# ACTION-IF-FALSE are run. Note if $PERL is not set (for example by +# running AC_CHECK_PROG or AC_PATH_PROG) the macro will fail. +# +# Example: +# +# AC_PATH_PROG([PERL],[perl]) +# AX_PROG_PERL_VERSION([5.8.0],[ ... ],[ ... ]) +# +# This will check to make sure that the perl you have supports at least +# version 5.8.0. +# +# NOTE: This macro uses the $PERL variable to perform the check. +# AX_WITH_PERL can be used to set that variable prior to running this +# macro. The $PERL_VERSION variable will be valorized with the detected +# version. +# +# LICENSE +# +# Copyright (c) 2009 Francesco Salvestrini +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice +# and this notice are preserved. This file is offered as-is, without any +# warranty. + +#serial 13 + +AC_DEFUN([AX_PROG_PERL_VERSION],[ + AC_REQUIRE([AC_PROG_SED]) + AC_REQUIRE([AC_PROG_GREP]) + + AS_IF([test -n "$PERL"],[ + ax_perl_version="$1" + + AC_MSG_CHECKING([for perl version]) + changequote(<<,>>) + perl_version=`$PERL --version 2>&1 \ + | $SED -n -e '/This is perl/b inspect +b +: inspect +s/.* (\{0,1\}v\([0-9]*\.[0-9]*\.[0-9]*\))\{0,1\} .*/\1/;p'` + changequote([,]) + AC_MSG_RESULT($perl_version) + + AC_SUBST([PERL_VERSION],[$perl_version]) + + AX_COMPARE_VERSION([$ax_perl_version],[le],[$perl_version],[ + : + $2 + ],[ + : + $3 + ]) + ],[ + AC_MSG_WARN([could not find the perl interpreter]) + $3 + ]) +]) diff -Nru ddclient-3.9.1/m4/ax_with_prog.m4 ddclient-3.10.0/m4/ax_with_prog.m4 --- ddclient-3.9.1/m4/ax_with_prog.m4 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/m4/ax_with_prog.m4 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,70 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_with_prog.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_WITH_PROG([VARIABLE],[program],[VALUE-IF-NOT-FOUND],[PATH]) +# +# DESCRIPTION +# +# Locates an installed program binary, placing the result in the precious +# variable VARIABLE. Accepts a present VARIABLE, then --with-program, and +# failing that searches for program in the given path (which defaults to +# the system path). If program is found, VARIABLE is set to the full path +# of the binary; if it is not found VARIABLE is set to VALUE-IF-NOT-FOUND +# if provided, unchanged otherwise. +# +# A typical example could be the following one: +# +# AX_WITH_PROG(PERL,perl) +# +# NOTE: This macro is based upon the original AX_WITH_PYTHON macro from +# Dustin J. Mitchell . +# +# LICENSE +# +# Copyright (c) 2008 Francesco Salvestrini +# Copyright (c) 2008 Dustin J. Mitchell +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice +# and this notice are preserved. This file is offered as-is, without any +# warranty. + +#serial 17 + +AC_DEFUN([AX_WITH_PROG],[ + AC_PREREQ([2.61]) + + pushdef([VARIABLE],$1) + pushdef([EXECUTABLE],$2) + pushdef([VALUE_IF_NOT_FOUND],$3) + pushdef([PATH_PROG],$4) + + AC_ARG_VAR(VARIABLE,Absolute path to EXECUTABLE executable) + + AS_IF(test -z "$VARIABLE",[ + AC_MSG_CHECKING(whether EXECUTABLE executable path has been provided) + AC_ARG_WITH(EXECUTABLE,AS_HELP_STRING([--with-EXECUTABLE=[[[PATH]]]],absolute path to EXECUTABLE executable), [ + AS_IF([test "$withval" != yes && test "$withval" != no],[ + VARIABLE="$withval" + AC_MSG_RESULT($VARIABLE) + ],[ + VARIABLE="" + AC_MSG_RESULT([no]) + AS_IF([test "$withval" != no], [ + AC_PATH_PROG([]VARIABLE[],[]EXECUTABLE[],[]VALUE_IF_NOT_FOUND[],[]PATH_PROG[]) + ]) + ]) + ],[ + AC_MSG_RESULT([no]) + AC_PATH_PROG([]VARIABLE[],[]EXECUTABLE[],[]VALUE_IF_NOT_FOUND[],[]PATH_PROG[]) + ]) + ]) + + popdef([PATH_PROG]) + popdef([VALUE_IF_NOT_FOUND]) + popdef([EXECUTABLE]) + popdef([VARIABLE]) +]) diff -Nru ddclient-3.9.1/Makefile.am ddclient-3.10.0/Makefile.am --- ddclient-3.9.1/Makefile.am 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/Makefile.am 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,155 @@ +ACLOCAL_AMFLAGS = -I m4 +EXTRA_DIST = \ + CONTRIBUTING.md \ + COPYING \ + COPYRIGHT \ + ChangeLog.md \ + README.cisco \ + README.md \ + README.ssl \ + autogen \ + sample-ddclient-wrapper.sh \ + sample-etc_cron.d_ddclient \ + sample-etc_dhclient-exit-hooks \ + sample-etc_dhcpc_dhcpcd-eth0.exe \ + sample-etc_ppp_ip-up.local \ + sample-etc_rc.d_ddclient.freebsd \ + sample-etc_rc.d_init.d_ddclient \ + sample-etc_rc.d_init.d_ddclient.alpine \ + sample-etc_rc.d_init.d_ddclient.lsb \ + sample-etc_rc.d_init.d_ddclient.redhat \ + sample-etc_rc.d_init.d_ddclient.ubuntu \ + sample-etc_systemd.service \ + sample-get-ip-from-fritzbox +CLEANFILES = + +# Command that replaces substitution variables with their values. +subst = sed \ + -e 's|@PACKAGE_VERSION[@]|$(PACKAGE_VERSION)|g' \ + -e '1 s|^\#\!.*perl$$|\#\!$(PERL)|g' \ + -e 's|@localstatedir[@]|$(localstatedir)|g' \ + -e 's|@runstatedir[@]|$(runstatedir)|g' \ + -e 's|@sysconfdir[@]|$(sysconfdir)|g' \ + -e 's|@CURL[@]|$(CURL)|g' + +# Files that will be generated by passing their *.in file through +# $(subst). +subst_files = ddclient ddclient.conf + +EXTRA_DIST += $(subst_files:=.in) +CLEANFILES += $(subst_files) + +$(subst_files): Makefile + rm -f '$@' '$@'.tmp + in='$@'.in; \ + test -f "$${in}" || in='$(srcdir)/'$${in}; \ + $(subst) "$${in}" >'$@'.tmp && \ + { ! test -x "$${in}" || chmod +x '$@'.tmp; } + mv '$@'.tmp '$@' + +ddclient: $(srcdir)/ddclient.in +ddclient.conf: $(srcdir)/ddclient.conf.in + +bin_SCRIPTS = ddclient + +sysconf_DATA = ddclient.conf + +install-data-local: + $(MKDIR_P) '$(DESTDIR)$(localstatedir)'/cache/ddclient + +AM_TESTS_ENVIRONMENT = \ + abs_top_srcdir='$(abs_top_srcdir)'; export abs_top_srcdir; +LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(top_srcdir)/build-aux/tap-driver.sh +TEST_EXTENSIONS = .pl +PL_LOG_DRIVER = $(LOG_DRIVER) +PL_LOG_COMPILER = $(PERL) +AM_PL_LOG_FLAGS = -Mstrict -w \ + -I'$(abs_top_builddir)' \ + -I'$(abs_top_srcdir)'/t/lib \ + -MDevel::Autoflush +handwritten_tests = \ + t/get_ip_from_if.pl \ + t/geturl_ssl.pl \ + t/is-and-extract-ipv4.pl \ + t/is-and-extract-ipv6.pl \ + t/is-and-extract-ipv6-global.pl \ + t/parse_assignments.pl \ + t/write_cache.pl +generated_tests = \ + t/geturl_connectivity.pl \ + t/version.pl +TESTS = $(handwritten_tests) $(generated_tests) +EXTRA_DIST += $(handwritten_tests) \ + t/lib/Devel/Autoflush.pm \ + t/lib/Test/Builder.pm \ + t/lib/Test/Builder/Formatter.pm \ + t/lib/Test/Builder/IO/Scalar.pm \ + t/lib/Test/Builder/Module.pm \ + t/lib/Test/Builder/Tester.pm \ + t/lib/Test/Builder/Tester/Color.pm \ + t/lib/Test/Builder/TodoDiag.pm \ + t/lib/Test/More.pm \ + t/lib/Test/Simple.pm \ + t/lib/Test/Tester.pm \ + t/lib/Test/Tester/Capture.pm \ + t/lib/Test/Tester/CaptureRunner.pm \ + t/lib/Test/Tester/Delegate.pm \ + t/lib/Test/use/ok.pm \ + t/lib/Test2.pm \ + t/lib/Test2/API.pm \ + t/lib/Test2/API/Breakage.pm \ + t/lib/Test2/API/Context.pm \ + t/lib/Test2/API/Instance.pm \ + t/lib/Test2/API/Stack.pm \ + t/lib/Test2/Event.pm \ + t/lib/Test2/Event/Bail.pm \ + t/lib/Test2/Event/Diag.pm \ + t/lib/Test2/Event/Encoding.pm \ + t/lib/Test2/Event/Exception.pm \ + t/lib/Test2/Event/Fail.pm \ + t/lib/Test2/Event/Generic.pm \ + t/lib/Test2/Event/Note.pm \ + t/lib/Test2/Event/Ok.pm \ + t/lib/Test2/Event/Pass.pm \ + t/lib/Test2/Event/Plan.pm \ + t/lib/Test2/Event/Skip.pm \ + t/lib/Test2/Event/Subtest.pm \ + t/lib/Test2/Event/TAP/Version.pm \ + t/lib/Test2/Event/V2.pm \ + t/lib/Test2/Event/Waiting.pm \ + t/lib/Test2/EventFacet.pm \ + t/lib/Test2/EventFacet/About.pm \ + t/lib/Test2/EventFacet/Amnesty.pm \ + t/lib/Test2/EventFacet/Assert.pm \ + t/lib/Test2/EventFacet/Control.pm \ + t/lib/Test2/EventFacet/Error.pm \ + t/lib/Test2/EventFacet/Hub.pm \ + t/lib/Test2/EventFacet/Info.pm \ + t/lib/Test2/EventFacet/Info/Table.pm \ + t/lib/Test2/EventFacet/Meta.pm \ + t/lib/Test2/EventFacet/Parent.pm \ + t/lib/Test2/EventFacet/Plan.pm \ + t/lib/Test2/EventFacet/Render.pm \ + t/lib/Test2/EventFacet/Trace.pm \ + t/lib/Test2/Formatter.pm \ + t/lib/Test2/Formatter/TAP.pm \ + t/lib/Test2/Hub.pm \ + t/lib/Test2/Hub/Interceptor.pm \ + t/lib/Test2/Hub/Interceptor/Terminator.pm \ + t/lib/Test2/Hub/Subtest.pm \ + t/lib/Test2/IPC.pm \ + t/lib/Test2/IPC/Driver.pm \ + t/lib/Test2/IPC/Driver/Files.pm \ + t/lib/Test2/Tools/Tiny.pm \ + t/lib/Test2/Util.pm \ + t/lib/Test2/Util/ExternalMeta.pm \ + t/lib/Test2/Util/Facets2Legacy.pm \ + t/lib/Test2/Util/HashBase.pm \ + t/lib/Test2/Util/Trace.pm \ + t/lib/ddclient/Test/Fake/HTTPD.pm \ + t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem \ + t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem \ + t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem \ + t/lib/ddclient/t.pm \ + t/lib/ok.pm diff -Nru ddclient-3.9.1/README.md ddclient-3.10.0/README.md --- ddclient-3.9.1/README.md 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/README.md 2022-10-20 18:06:35.000000000 +0000 @@ -1,29 +1,25 @@ -=============================================================================== -# DDCLIENT v3.9.1 +# DDCLIENT v3.10.0 -ddclient is a Perl client used to update dynamic DNS entries for accounts +`ddclient` is a Perl client used to update dynamic DNS entries for accounts on many dynamic DNS services. -=============================================================================== +## Supported services Dynamic DNS services currently supported include: DynDNS.com - See http://www.dyndns.com for details on obtaining a free account. - Hammernode - See http://www.hn.org for details on obtaining a free account. Zoneedit - See http://www.zoneedit.com for details. EasyDNS - See http://www.easydns.com for details. NameCheap - See http://www.namecheap.com for details - ConCont - See http://www.dydns.za.net for details - DnsPark - See http://www.dnspark.com for details DslReports - See http://www.dslreports.com for details Sitelutions - See http://www.sitelutions.com for details Loopia - See http://www.loopia.se for details Noip - See http://www.noip.com/ for details Freedns - See http://freedns.afraid.org/ for details ChangeIP - See http://www.changeip.com/ for details - dtdns - See http://www.dtdns.com/ for details nsupdate - See nsupdate(1) and ddns-confgen(8) for details CloudFlare - See https://www.cloudflare.com/ for details + GoDaddy - See https://www.godaddy.com/ for details Google - See http://www.google.com/domains for details Duckdns - See https://duckdns.org/ for details Freemyip - See https://freemyip.com for details @@ -32,123 +28,204 @@ DNS Made Easy - See https://dnsmadeeasy.com/ for details DonDominio - See https://www.dondominio.com for details NearlyFreeSpeech.net - See https://www.nearlyfreespeech.net/services/dns for details + OVH - See https://www.ovh.com for details + ClouDNS - See https://www.cloudns.net + dinahosting - See https://dinahosting.com + Gandi - See https://gandi.net + dnsexit - See https://dnsexit.com/ for details + 1984.is - See https://www.1984.is/product/freedns/ for details + Njal.la - See https://njal.la/docs/ddns/ -DDclient now supports many of cable/dsl broadband routers. +`ddclient` now supports many cable and DSL broadband routers. -Comments, suggestions and requests: use the issues on - https://github.com/ddclient/ddclient/issues/new +Comments, suggestions and requests: use the issues on https://github.com/ddclient/ddclient/issues/new -The code was originally written by Paul Burry and is now hosted and maintained +The code was originally written by Paul Burry and is now hosted and maintained through github.com. Please check out http://ddclient.net -------------------------------------------------------------------------------- -## REQUIREMENTS: +## REQUIREMENTS -- one or more accounts from one of the dynamic DNS services + * An account from a supported dynamic DNS service provider + * Perl v5.10.1 or later + * `IO::Socket::SSL` perl library for ssl-support + * `JSON::PP` perl library for JSON support + * `IO::Socket::INET6` perl library for ipv6-support + * Linux, macOS, or any other Unix-ish system + * An implementation of `make` (such as [GNU + Make](https://www.gnu.org/software/make/)) + * If you are installing from a clone of the Git repository, you will + also need [GNU Autoconf](https://www.gnu.org/software/autoconf/) + and [GNU Automake](https://www.gnu.org/software/automake/). + +## DOWNLOAD + +See https://github.com/ddclient/ddclient/releases + +## INSTALLATION + +### Distribution Package + + + Packaging status + +The easiest way to install ddclient is to install a package offered by your +operating system. See the image to the right for a list of distributions with a +ddclient package. + +### Manual Installation + + 1. Extract the distribution tarball (`.tar.gz` file) and `cd` into + the directory: + + ```shell + tar xvfa ddclient-3.10.0.tar.gz + cd ddclient-3.10.0 + ``` + + (If you are installing from a clone of the Git repository, you + must run `./autogen` before continuing to the next step.) + + 2. Run the following commands to build and install: + + ```shell + ./configure \ + --prefix=/usr \ + --sysconfdir=/etc/ddclient \ + --localstatedir=/var + make + make VERBOSE=1 check + sudo make install + ``` -- Perl 5.014 or later - - `Data::Validate::IP` perl library - - `IO::Socket::SSL` perl library for ssl-support - - `JSON::PP` perl library for JSON support - - `IO::Socket:INET6` perl library for ipv6-support - -- Linux or probably any common Unix system - -------------------------------------------------------------------------------- -## INSTALLATION: - - cp ddclient /usr/sbin/ - mkdir /etc/ddclient - mkdir /var/cache/ddclient - cp sample-etc_ddclient.conf /etc/ddclient/ddclient.conf - vi /etc/ddclient/ddclient.conf - -- and change hostnames, logins, and passwords appropriately + 3. Edit `/etc/ddclient/ddclient.conf`. + +#### systemd - ## For those using systemd: cp sample-etc_systemd.service /etc/systemd/system/ddclient.service - ## enable automatic startup when booting + +enable automatic startup when booting + systemctl enable ddclient.service - ## start the first time by hand + +start the first time by hand + systemctl start ddclient.service - ## For those using Redhat style rc files and using daemon-mode: +#### Redhat style rc files and daemon-mode + cp sample-etc_rc.d_init.d_ddclient /etc/rc.d/init.d/ddclient - ## enable automatic startup when booting - ## check your distribution + +enable automatic startup when booting. also check your distribution + /sbin/chkconfig --add ddclient - ## start the first time by hand + +start the first time by hand + /etc/rc.d/init.d/ddclient start - ## For those using Alpine style rc files and using daemon-mode: +#### Alpine style rc files and daemon-mode + cp sample-etc_rc.d_init.d_ddclient.alpine /etc/init.d/ddclient - ## enable automatic startup when booting + +enable automatic startup when booting + rc-update add ddclient - ## make sure you have perl installed + +make sure you have perl installed + apk add perl - ## start the first time by hand + +start the first time by hand + rc-service ddclient start - ## For those using Ubuntu style rc files and using daemon-mode: +#### Ubuntu style rc files and daemon-mode + cp sample-etc_rc.d_init.d_ddclient.ubuntu /etc/init.d/ddclient - ## enable automatic startup when booting + +enable automatic startup when booting + update-rc.d ddclient defaults - ## make sure you have perl and the required modules installed - apt-get install perl libdata-validate-ip-perl - ## if you plan to use cloudflare or feedns you need the perl json module - apt-get install libjson-any-perl - ## start the first time by hand + +make sure you have perl and the required modules installed + + apt-get install perl libdata-validate-ip-perl libio-socket-ssl-perl + +if you plan to use cloudflare or feedns you need the perl json module + + apt-get install libjson-pp-perl + +for IPv6 you also need to instal the perl io-socket-inet6 module + + apt install libio-socket-inet6-perl + +start the first time by hand + service ddclient start - ## If you are not using daemon-mode, configure cron and dhcp or ppp - ## as described below. +#### FreeBSD style rc files and daemon mode + + mkdir -p /usr/local/etc/rc.d + cp sample-etc_rc.d_ddclient.freebsd /usr/local/etc/rc.d/ddclient + +enable automatic startup when booting + + sysrc ddclient_enable=YES + +make sure you have perl and the required modules installed + + pkg install perl5 p5-Data-Validate-IP p5-IO-Socket-SSL -------------------------------------------------------------------------------- -## TROUBLESHOOTING: +if you plan to use cloudflare or feedns you need the perl json module - 1. enable debugging and verbose messages. - ``$ ddclient -daemon=0 -debug -verbose -noquiet`` + pkg install p5-JSON-PP + +start the service manually for the first time + + service ddclient start + + +If you are not using daemon-mode, configure cron and dhcp or ppp as described below. + +## TROUBLESHOOTING + + 1. enable debugging and verbose messages: ``$ ddclient -daemon=0 -debug -verbose -noquiet`` 2. Do you need to specify a proxy? - If so, just add a - ``proxy=your.isp.proxy`` - to the ddclient.conf file. + If so, just add a ``proxy=your.isp.proxy`` to the ddclient.conf file. 3. Define the IP address of your router with ``fw=xxx.xxx.xxx.xxx`` in - ``/etc/ddclient/ddclient.conf`` and then try - ``$ ddclient -daemon=0 -query`` - to see if the router status web page can be understood. + ``/etc/ddclient/ddclient.conf`` and then try ``$ ddclient -daemon=0 -query`` to see if the router status web page can be understood. 4. Need support for another router/firewall? - Define the router status page yourself with: - ``fw=url-to-your-router``'s-status-page - ``fw-skip=any-string-preceding-your-IP-address`` + Define the router status page yourself with: ``fw=url-to-your-router``'s-status-page ``fw-skip=any-string-preceding-your-IP-address`` ddclient does something like this to provide builtin support for common routers. For example, the Linksys routers could have been added with: - fw=192.168.1.1/Status.htm - fw-skip=WAN.*?IP Address + fw=192.168.1.1/Status.htm + fw-skip=WAN.*?IP Address - OR +OR Send me the output from: - $ ddclient -geturl {fw-ip-status-url} [-login login [-password password]] + ``$ ddclient -geturl {fw-ip-status-url} [-login login [-password password]]`` and I'll add it to the next release! - ie. for my fw/router I used: - $ ddclient -geturl 192.168.1.254/status.htm +ie. for my fw/router I used: ``$ ddclient -geturl 192.168.1.254/status.htm`` 5. Some broadband routers require the use of a password when ddclient accesses its status page to determine the router's WAN IP address. If this is the case for your router, add - fw-login=your-router-login - fw-password=your-router-password - to the beginning of your ddclient.conf file. - Note that some routers use either 'root' or 'admin' as their login - while some others accept anything. -------------------------------------------------------------------------------- -## USING DDCLIENT WITH ppp + fw-login=your-router-login + fw-password=your-router-password + +to the beginning of your ddclient.conf file. +Note that some routers use either 'root' or 'admin' as their login +while some others accept anything. + +## USING DDCLIENT WITH `ppp` If you are using a ppp connection, you can easily update your DynDNS entry with each connection, with: @@ -159,8 +236,7 @@ Alternatively, you may just configure ddclient to operate as a daemon and monitor your ppp interface. -------------------------------------------------------------------------------- -## USING DDCLIENT WITH cron +## USING DDCLIENT WITH `cron` If you have not configured ddclient to use daemon-mode, you'll need to configure cron to force an update once a month so that the dns entry will @@ -170,23 +246,24 @@ cp sample-etc_cron.d_ddclient /etc/cron.d/ddclient vi /etc/cron.d/ddclient -------------------------------------------------------------------------------- -## USING DDCLIENT WITH dhcpcd-1.3.17 +## USING DDCLIENT WITH `dhcpcd-1.3.17` If you are using dhcpcd-1.3.17 or thereabouts, you can easily update your DynDNS entry automatically every time your lease is obtained or renewed by creating an executable file named: - /etc/dhcpc/dhcpcd-{your-interface}.exe + ``/etc/dhcpc/dhcpcd-{your-interface}.exe`` ie.: - cp sample-etc_dhcpc_dhcpcd-eth0.exe /etc/dhcpc/dhcpcd-{your-interface}.exe + ``cp sample-etc_dhcpc_dhcpcd-eth0.exe /etc/dhcpc/dhcpcd-{your-interface}.exe`` In my case, it is named dhcpcd-eth0.exe and contains the lines: - #!/bin/sh - PATH=/usr/sbin:/root/bin:${PATH} - logger -t dhcpcd IP address changed to $1 - ddclient -proxy fasthttp.sympatico.ca -wildcard -ip $1 | logger -t ddclient - exit 0 +```shell +#!/bin/sh +PATH=/usr/bin:/root/bin:${PATH} +logger -t dhcpcd IP address changed to $1 +ddclient -proxy fasthttp.sympatico.ca -wildcard -ip $1 | logger -t ddclient +exit 0 +``` Other DHCP clients may have another method of calling out to programs for updating DNS entries. @@ -194,19 +271,16 @@ Alternatively, you may just configure ddclient to operate as a daemon and monitor your ethernet interface. -------------------------------------------------------------------------------- -## USING DDCLIENT WITH dhclient +## USING DDCLIENT WITH `dhclient` If you are using the ISC DHCP client (dhclient), you can update your DynDNS entry automatically every time your lease is obtained or renewed by creating an executable file named: - /etc/dhclient-exit-hooks + ``/etc/dhclient-exit-hooks`` ie.: - cp sample-etc_dhclient-exit-hooks /etc/dhclient-exit-hooks + ``cp sample-etc_dhclient-exit-hooks /etc/dhclient-exit-hooks`` -Edit /etc/dhclient-exit-hooks to change any options required. +Edit ``/etc/dhclient-exit-hooks`` to change any options required. Alternatively, you may just configure ddclient to operate as a daemon and monitor your ethernet interface. - -------------------------------------------------------------------------------- diff -Nru ddclient-3.9.1/RELEASENOTE ddclient-3.10.0/RELEASENOTE --- ddclient-3.9.1/RELEASENOTE 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/RELEASENOTE 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -Yet again it's been a while but here is new release of ddclient. As usual, -there are some important changes and some documentation is modified. -A detailed overview can be found in git log but here's a quick overview: - - * added support for Yandex.Mail for Domain DNS service - * added support for NearlyFreeSpeech.net - * added support for DNS Made Easy - * added systemd instructions - * added support for dondominio.com - * updated perl instruction - * updated fritzbox instructions - * fixed multidomain support for namecheap - * fixed support for Yandex - -A very big thank you for everyone who created a pull request on github and -for everyone who helped to fix the little issues caused by the new providers. -And a very special thank you for @DaveSophoServices who started to help with -the maintenance of ddclient. diff -Nru ddclient-3.9.1/sample-etc_cron.d_ddclient ddclient-3.10.0/sample-etc_cron.d_ddclient --- ddclient-3.9.1/sample-etc_cron.d_ddclient 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_cron.d_ddclient 2022-10-20 18:06:35.000000000 +0000 @@ -9,8 +9,8 @@ ###################################################################### ## force an update twice a month (only if you are not using daemon-mode) ## -## 30 23 1,15 * * root /usr/sbin/ddclient -daemon=0 -syslog -quiet -force +## 30 23 1,15 * * root /usr/bin/ddclient -daemon=0 -syslog -quiet -force ###################################################################### ## retry failed updates every hour (only if you are not using daemon-mode) ## -## 0 * * * * root /usr/sbin/ddclient -daemon=0 -syslog -quiet retry +## 0 * * * * root /usr/bin/ddclient -daemon=0 -syslog -quiet retry diff -Nru ddclient-3.9.1/sample-etc_ddclient.conf ddclient-3.10.0/sample-etc_ddclient.conf --- ddclient-3.9.1/sample-etc_ddclient.conf 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_ddclient.conf 1970-01-01 00:00:00.000000000 +0000 @@ -1,287 +0,0 @@ -###################################################################### -## -## Define default global variables with lines like: -## var=value [, var=value]* -## These values will be used for each following host unless overridden -## with a local variable definition. -## -## Define local variables for one or more hosts with: -## var=value [, var=value]* host.and.domain[,host2.and.domain...] -## -## Lines can be continued on the following line by ending the line -## with a \ -## -## -## Warning: not all supported routers or dynamic DNS services -## are mentioned here. -## -###################################################################### -daemon=300 # check every 300 seconds -syslog=yes # log update msgs to syslog -mail=root # mail all msgs to root -mail-failure=root # mail failed update msgs to root -pid=/var/run/ddclient.pid # record PID in file. -ssl=yes # use ssl-support. Works with - # ssl-library -# postscript=script # run script after updating. The - # new IP is added as argument. -# -#use=watchguard-soho, fw=192.168.111.1:80 # via Watchguard's SOHO FW -#use=netopia-r910, fw=192.168.111.1:80 # via Netopia R910 FW -#use=smc-barricade, fw=192.168.123.254:80 # via SMC's Barricade FW -#use=netgear-rt3xx, fw=192.168.0.1:80 # via Netgear's internet FW -#use=linksys, fw=192.168.1.1:80 # via Linksys's internet FW -#use=maxgate-ugate3x00, fw=192.168.0.1:80 # via MaxGate's UGATE-3x00 FW -#use=elsa-lancom-dsl10, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router -#use=elsa-lancom-dsl10-ch01, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router -#use=elsa-lancom-dsl10-ch02, fw=10.0.0.254:80 # via ELSA LanCom DSL/10 DSL Router -#use=alcatel-stp, fw=10.0.0.138:80 # via Alcatel Speed Touch Pro -#use=xsense-aero, fw=192.168.1.1:80 # via Xsense Aero Router -#use=allnet-1298, fw=192.168.1.1:80 # via AllNet 1298 DSL Router -#use=3com-oc-remote812, fw=192.168.0.254:80 # via 3com OfficeConnect Remote 812 -#use=e-tech, fw=192.168.1.1:80 # via E-tech Router -#use=cayman-3220h, fw=192.168.0.1:1080 # via Cayman 3220-H DSL Router -# -#fw-login=admin, fw-password=XXXXXX # FW login and password -# -## To obtain an IP address from FW status page (using fw-login, fw-password) -#use=fw, fw=192.168.1.254/status.htm, fw-skip='IP Address' # found after IP Address -# -## To obtain an IP address from Web status page (using the proxy if defined) -## by default, checkip.dyndns.org is used if you use the dyndns protocol. -## Using use=web is enough to get it working. -## WARNING: set deamon at least to 600 seconds if you use checkip or you could -## get banned from their service. -#use=web, web=checkip.dyndns.org/, web-skip='IP Address' # found after IP Address -# -#use=ip, ip=127.0.0.1 # via static IP's -#use=if, if=eth0 # via interfaces -#use=web # via web -# -#protocol=dyndns2 # default protocol -#proxy=fasthttp.sympatico.ca:80 # default proxy -#server=members.dyndns.org # default server -#server=members.dyndns.org:8245 # default server (bypassing proxies) - -#login=your-login # default login -#password=test # default password -#mx=mx.for.your.host # default MX -#backupmx=yes|no # host is primary MX? -#wildcard=yes|no # add wildcard CNAME? - -## -## dyndns.org dynamic addresses -## -## (supports variables: wildcard,mx,backupmx) -## -# server=members.dyndns.org, \ -# protocol=dyndns2 \ -# your-dynamic-host.dyndns.org - -## -## dyndns.org static addresses -## -## (supports variables: wildcard,mx,backupmx) -## -# static=yes, \ -# server=members.dyndns.org, \ -# protocol=dyndns2 \ -# your-static-host.dyndns.org - -## -## -## dyndns.org custom addresses -## -## (supports variables: wildcard,mx,backupmx) -## -# custom=yes, \ -# server=members.dyndns.org, \ -# protocol=dyndns2 \ -# your-domain.top-level,your-other-domain.top-level - -## -## ZoneEdit (zoneedit.com) -## -# server=dynamic.zoneedit.com, \ -# protocol=zoneedit1, \ -# login=your-zoneedit-login, \ -# password=your-zoneedit-password \ -# your.any.domain,your-2nd.any.dom - -## -## EasyDNS (easydns.com) -## -# server=members.easydns.com, \ -# protocol=easydns, \ -# login=your-easydns-login, \ -# password=your-easydns-password \ -# your.any.domain,your-2nd.any.domain - -## -## Hammernode (hn.org) dynamic addresses -## -# server=dup.hn.org, \ -# protocol=hammernode1, \ -# login=your-hn-login, \ -# password=your-hn-password \ -# your-hn-host.hn.org,your-2nd-hn-host.hn.org - -## -## dslreports.com dynamic-host monitoring -## -# server=members.dslreports.com \ -# protocol=dslreports1, \ -# login=dslreports-login, \ -# password=dslreports-password \ -# dslreports-unique-id - -## -## OrgDNS.org account-configuration -## -# use=web, web=members.orgdns.org/nic/ip -# server=www.orgdns.org \ -# protocol=dyndns2 \ -# login=yourLoginName \ -# password=yourPassword \ -# yourSubdomain.orgdns.org - -## -## dnspark.com -## (supports variables: mx, mxpri) -## -# use=web, web=ipdetect.dnspark.com, web-skip='Current Address:' -# protocol=dnspark, \ -# server=www.dnspark.com, \ -# your-host.dnspark.com - -## -## NameCheap (namecheap.com) -## -# protocol=namecheap, \ -# server=dynamicdns.park-your-domain.com, \ -# login=my-namecheap.com-login, \ -# password=my-namecheap.com-password \ -# fully.qualified.host - -## -## NearlyFreeSpeech.NET (nearlyfreespeech.net) -## -# protocol = nfsn, \ -# login=member-login, \ -# password=api-key, \ -# zone=example.com \ -# example.com,subdomain.example.com - -## -## -## Loopia (loopia.se) -## -# use=web -# web=loopia -# protocol=dyndns2 -# server=dns.loopia.se -# script=/XDynDNSServer/XDynDNS.php -# login=my-loopia.se-login -# password=my-loopia.se-password -# my.domain.tld,other.domain.tld - -## -## -## ChangeIP (changeip.com) -## -## single host update -# protocol=changeip, \ -# login=my-my-changeip.com-login, \ -# password=my-changeip.com-password \ -# myhost.changeip.org - -## -## DtDNS (www.dtdns.com) -## -# protocol=dtdns, -# server=www.dtdns.com, -# client=ddclient, -# password=my-dtdns.com-password -# myhost.dtdns.net, otherhost.dtdns.net - -## -## CloudFlare (www.cloudflare.com) -## -#protocol=cloudflare, \ -#zone=domain.tld, \ -#ttl=1, \ -#login=your-login-email, \ -#password=APIKey \ -#domain.tld,my.domain.tld - -## -## Google Domains (www.google.com/domains) -## -# protocol=googledomains, -# login=my-auto-generated-username, -# password=my-auto-generated-password -# my.domain.tld, otherhost.domain.tld - -## -## Duckdns (http://www.duckdns.org/) -## -# -# password=my-auto-generated-password -# protocol=duckdns hostwithoutduckdnsorg - -## -## Freemyip (http://freemyip.com/) -## -# -# protocol=freemyip, -# password=my-token -# myhost - -## -## MyOnlinePortal (http://myonlineportal.net) -## -# protocol=dyndns2 -# ssl=yes -# # ipv6=yes # optional -# use=web, web=myonlineportal.net/checkip -# # use=if, if=eth0 # alternative to use=web -# # if-skip=Scope:Link # alternative to use=web -# login=your-myonlineportal-username -# password=your-myonlineportal-password -# domain.myonlineportal.net - -## -## nsupdate.info IPV4(https://www.nsupdate.info) -## -#protocol=dyndns2 -#use=web, web=http://ipv4.nsupdate.info/myip -#server=ipv4.nsupdate.info -#login=domain.nsupdate.info -#password='123' -#domain.nsupdate.info - -## -## nsupdate.info IPV6 (https://www.nsupdate.info) -## ddclient releases <= 3.8.1 do not support IPv6 -## -#protocol=dyndns2 -#usev6=if, if=eth0 -#server=ipv6.nsupdate.info -#login=domain.nsupdate.info -#password='123' -#domain.nsupdate.info - -## -## Yandex.Mail for Domain (domain.yandex.com) -## -# protocol=yandex, \ -# login=domain.tld, \ -# password=yandex-pdd-token \ -# my.domain.tld,other.domain.tld \ - -## DNS Made Easy (https://dnsmadeeasy.com) -## -# protocol=dnsmadeeasy, -# login=your-account-email-address -# password=your-generated-password -# your-numeric-record-id-1,your-numeric-record-id-2,... diff -Nru ddclient-3.9.1/sample-etc_dhclient-exit-hooks ddclient-3.10.0/sample-etc_dhclient-exit-hooks --- ddclient-3.9.1/sample-etc_dhclient-exit-hooks 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_dhclient-exit-hooks 2022-10-20 18:06:35.000000000 +0000 @@ -3,7 +3,7 @@ # The /etc/dhclient-enter-hooks script is run by the ISC DHCP client's standard # update script whenever dhclient obtains or renews an address. -PATH=/usr/sbin:${PATH} +PATH=/usr/bin:${PATH} case "$new_ip_address" in 10.*) ;; 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; diff -Nru ddclient-3.9.1/sample-etc_dhcpc_dhcpcd-eth0.exe ddclient-3.10.0/sample-etc_dhcpc_dhcpcd-eth0.exe --- ddclient-3.9.1/sample-etc_dhcpc_dhcpcd-eth0.exe 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_dhcpc_dhcpcd-eth0.exe 2022-10-20 18:06:35.000000000 +0000 @@ -1,6 +1,6 @@ #!/bin/sh ###################################################################### -PATH=/usr/sbin:${PATH} +PATH=/usr/bin:${PATH} ## update the DNS server unless the IP address is a private address ## that may be used as an internal LAN address. This may be true if diff -Nru ddclient-3.9.1/sample-etc_ppp_ip-up.local ddclient-3.10.0/sample-etc_ppp_ip-up.local --- ddclient-3.9.1/sample-etc_ppp_ip-up.local 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_ppp_ip-up.local 2022-10-20 18:06:35.000000000 +0000 @@ -14,7 +14,7 @@ ## in the environment as either PPP_LOCAL or IPLOCAL. ## ###################################################################### -PATH=/usr/sbin:${PATH} +PATH=/usr/bin:${PATH} IP= IP=${IP:-$PPP_LOCAL} IP=${IP:-$IPLOCAL} diff -Nru ddclient-3.9.1/sample-etc_rc.d_ddclient.freebsd ddclient-3.10.0/sample-etc_rc.d_ddclient.freebsd --- ddclient-3.9.1/sample-etc_rc.d_ddclient.freebsd 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/sample-etc_rc.d_ddclient.freebsd 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,31 @@ +#!/bin/sh + +# PROVIDE: ddclient +# REQUIRE: LOGIN +# KEYWORD: shutdown +# +# Add the following lines to /etc/rc.conf.local or /etc/rc.conf +# to enable this service: +# +# ddclient_enable (bool): Set to NO by default. +# Set it to YES to enable ddclient. + +. /etc/rc.subr + +name=ddclient +rcvar=ddclient_enable +ddclient_conf="/etc/ddclient/ddclient.conf" + +command="/usr/local/sbin/${name}" +load_rc_config $name + +delay=$(grep -v '^\s*#' "${ddclient_conf}" | grep -i -m 1 "daemon" | awk -F '=' '{print $2}') + +if [ -z "${delay}" ] +then + ddclient_flags="-daemon 300" +else + ddclient_flags="" +fi + +run_rc_command "$1" diff -Nru ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient --- ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient 2022-10-20 18:06:35.000000000 +0000 @@ -28,64 +28,73 @@ PID=`ps -aef | grep "$program - sleep" | grep -v grep | awk '{print $2}'` fi -PATH=/usr/sbin:/usr/local/sbin:${PATH} +PATH=/usr/bin:/usr/local/bin:${PATH} export PATH # See how we were called. case "$1" in - start) - # Start daemon. - DELAY=`grep -v '^\s*#' $CONF | grep -i -m 1 "daemon" | awk -F '=' '{print $2}'` - if [ -z "$DELAY" ] ; then - DELAY="-daemon 300" - else - DELAY='' - fi - echo -n "Starting ddclient: " - if [ "$system" = "fedora" ] || [ "$system" = "redhat" ]; then - daemon $program $DELAY - else - ddclient $DELAY - fi - echo - ;; - stop) - # Stop daemon. - echo -n "Shutting down ddclient: " - if [ -n "$PID" ] ; then + start) + # See if daemon=value is specified in the config file. + # Assumptions: + # * there are no quoted "#" characters before "daemon=" + # (if there is a "#" it starts a comment) + # * "daemon=" does not appear in a password or value + # * if the interval value is 0, it is not quoted + INTERVAL=$(sed -e ' + s/^\([^#]*[,[:space:]]\)\{0,1\}daemon=\([^,[:space:]]*\).*$/\2/ + t quit + d + :quit + q + ' "$CONF") + if [ -z "$DELAY" ] || [ "$DELAY" = "0" ]; then + DELAY="-daemon 300" + else + # use the interval specified in the config file + DELAY='' + fi + echo -n "Starting ddclient: " if [ "$system" = "fedora" ] || [ "$system" = "redhat" ]; then - killproc $program + daemon $program $DELAY else - kill $PID + ddclient $DELAY fi - else - echo "ddclient is not running" - fi - echo - ;; - restart) - $0 stop - $0 start - ;; - status) - if [ "$system" = "fedora" ] || [ "$system" = "redhat" ]; then - status $program - else - if test "$PID" - then - for p in $PID - do - echo "$program (pid $p) is running" - done - else - echo "$program is stopped" + echo + ;; + stop) + # Stop daemon. + echo -n "Shutting down ddclient: " + if [ -n "$PID" ]; then + if [ "$system" = "fedora" ] || [ "$system" = "redhat" ]; then + killproc $program + else + kill $PID + fi + else + echo "ddclient is not running" fi - fi - ;; - *) - echo "Usage: ddclient {start|stop|restart|status}" - exit 1 + echo + ;; + restart) + $0 stop + $0 start + ;; + status) + if [ "$system" = "fedora" ] || [ "$system" = "redhat" ]; then + status $program + else + if test "$PID"; then + for p in $PID; do + echo "$program (pid $p) is running" + done + else + echo "$program is stopped" + fi + fi + ;; + *) + echo "Usage: ddclient {start|stop|restart|status}" + exit 1 esac exit 0 - diff -Nru ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.alpine ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.alpine --- ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.alpine 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.alpine 2022-10-20 18:06:35.000000000 +0000 @@ -1,6 +1,6 @@ #!/sbin/openrc-run description="ddclient Daemon for Alpine" -command="/usr/sbin/ddclient" +command="/usr/bin/ddclient" config_file="/etc/ddclient/ddclient.conf" command_args="" pidfile=$(grep -v '^\s*#' "${config_file}" | grep -i -m 1 pid= | awk -F '=' '{print $2}') diff -Nru ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.lsb ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.lsb --- ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.lsb 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.lsb 2022-10-20 18:06:35.000000000 +0000 @@ -25,7 +25,7 @@ [ -f /etc/ddclient/ddclient.conf ] || exit 0 -DDCLIENT_BIN=/usr/sbin/ddclient +DDCLIENT_BIN=/usr/bin/ddclient # # LSB Standard (SuSE,RedHat,...) diff -Nru ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.ubuntu ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.ubuntu --- ddclient-3.9.1/sample-etc_rc.d_init.d_ddclient.ubuntu 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_rc.d_init.d_ddclient.ubuntu 2022-10-20 18:06:35.000000000 +0000 @@ -9,7 +9,7 @@ # Description: Start ddclient that provides support for updating dynamic DNS services. Originally submitted by paolo martinelli, updated by joe passavanti ### END INIT INFO -DDCLIENT=/usr/sbin/ddclient +DDCLIENT=/usr/bin/ddclient CONF=/etc/ddclient/ddclient.conf PIDFILE=/var/run/ddclient.pid diff -Nru ddclient-3.9.1/sample-etc_systemd.service ddclient-3.10.0/sample-etc_systemd.service --- ddclient-3.9.1/sample-etc_systemd.service 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-etc_systemd.service 2022-10-20 18:06:35.000000000 +0000 @@ -1,11 +1,11 @@ [Unit] Description=Dynamic DNS Update Client -After=network.target +After=network.target network-online.target [Service] Type=forking -PIDFile=/var/run/ddclient.pid -ExecStart=/usr/sbin/ddclient +PIDFile=/run/ddclient.pid +ExecStart=/usr/bin/ddclient [Install] WantedBy=multi-user.target diff -Nru ddclient-3.9.1/sample-get-ip-from-fritzbox ddclient-3.10.0/sample-get-ip-from-fritzbox --- ddclient-3.9.1/sample-get-ip-from-fritzbox 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/sample-get-ip-from-fritzbox 2022-10-20 18:06:35.000000000 +0000 @@ -1,6 +1,6 @@ #!/bin/bash # -# Scirpt to fetch IP from fritzbox +# Script to fetch IP from fritzbox # # Contributed by @Rusk85 in request #45 # Script can be used in the configuration by adding diff -Nru ddclient-3.9.1/shell.nix ddclient-3.10.0/shell.nix --- ddclient-3.9.1/shell.nix 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/shell.nix 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,11 @@ +{ pkgs ? import { } }: + +with pkgs; + +mkShellNoCC { + buildInputs = [ + autoconf + automake + gnumake + ]; +} diff -Nru ddclient-3.9.1/t/get_ip_from_if.pl ddclient-3.10.0/t/get_ip_from_if.pl --- ddclient-3.9.1/t/get_ip_from_if.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/get_ip_from_if.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,63 @@ +use Test::More; +use ddclient::t; +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +# To aid in debugging, uncomment the following lines. (They are normally left commented to avoid +# accidentally interfering with the Test Anything Protocol messages written by Test::More.) +#STDOUT->autoflush(1); +#$ddclient::globals{'debug'} = 1; + +subtest "get_default_interface tests" => sub { + for my $sample (@ddclient::t::routing_samples) { + if (defined($sample->{want_ipv4_if})) { + my $interface = ddclient::get_default_interface(4, $sample->{text}); + is($interface, $sample->{want_ipv4_if}, $sample->{name}); + } + if (defined($sample->{want_ipv6_if})) { + my $interface = ddclient::get_default_interface(6, $sample->{text}); + is($interface, $sample->{want_ipv6_if}, $sample->{name}); + } + } +}; + +subtest "get_ip_from_interface tests" => sub { + for my $sample (@ddclient::t::interface_samples) { + # interface name is undef as we are passing in test data + if (defined($sample->{want_ipv4_from_if})) { + my $ip = ddclient::get_ip_from_interface(undef, 4, undef, $sample->{text}, $sample->{MacOS}); + is($ip, $sample->{want_ipv4_from_if}, $sample->{name}); + } + if (defined($sample->{want_ipv6gua_from_if})) { + my $ip = ddclient::get_ip_from_interface(undef, 6, 'gua', $sample->{text}, $sample->{MacOS}); + is($ip, $sample->{want_ipv6gua_from_if}, $sample->{name}); + } + if (defined($sample->{want_ipv6ula_from_if})) { + my $ip = ddclient::get_ip_from_interface(undef, 6, 'ula', $sample->{text}, $sample->{MacOS}); + is($ip, $sample->{want_ipv6ula_from_if}, $sample->{name}); + } + } +}; + +subtest "Get default interface and IP for test system" => sub { + my $interface = ddclient::get_default_interface(4); + if ($interface) { + isnt($interface, "lo", "Check for loopback 'lo'"); + isnt($interface, "lo0", "Check for loopback 'lo0'"); + my $ip1 = ddclient::get_ip_from_interface("default", 4); + my $ip2 = ddclient::get_ip_from_interface($interface, 4); + is($ip1, $ip2, "Check IPv4 from default interface"); + ok(ddclient::is_ipv4($ip1), "Valid IPv4 from get_ip_from_interface($interface)"); + } + $interface = ddclient::get_default_interface(6); + if ($interface) { + isnt($interface, "lo", "Check for loopback 'lo'"); + isnt($interface, "lo0", "Check for loopback 'lo0'"); + my $ip1 = ddclient::get_ip_from_interface("default", 6); + my $ip2 = ddclient::get_ip_from_interface($interface, 6); + is($ip1, $ip2, "Check IPv6 from default interface"); + ok(ddclient::is_ipv6($ip1), "Valid IPv6 from get_ip_from_interface($interface)"); + } +}; + +done_testing(); diff -Nru ddclient-3.9.1/t/geturl_connectivity.pl.in ddclient-3.10.0/t/geturl_connectivity.pl.in --- ddclient-3.9.1/t/geturl_connectivity.pl.in 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/geturl_connectivity.pl.in 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,114 @@ +use Test::More; +eval { require ddclient::Test::Fake::HTTPD; } or plan(skip_all => $@); +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); +my $has_http_daemon_ssl = eval { require HTTP::Daemon::SSL; }; +my $has_io_socket_inet6 = eval { require IO::Socket::INET6; }; +my $ipv6_supported = eval { + require IO::Socket::IP; + my $ipv6_socket = IO::Socket::IP->new( + Domain => 'PF_INET6', + LocalHost => '::1', + Listen => 1, + ); + defined($ipv6_socket); +}; +my $has_curl = qx{ @CURL@ --version 2>/dev/null; } && $? == 0; + +my $http_daemon_supports_ipv6 = eval { + require HTTP::Daemon; + HTTP::Daemon->VERSION(6.12); +}; + +# To aid in debugging, uncomment the following lines. (They are normally left commented to avoid +# accidentally interfering with the Test Anything Protocol messages written by Test::More.) +#STDOUT->autoflush(1); +#$ddclient::globals{'verbose'} = 1; + +my $certdir = "$ENV{abs_top_srcdir}/t/lib/ddclient/Test/Fake/HTTPD"; +$ddclient::globals{'ssl_ca_file'} = "$certdir/dummy-ca-cert.pem"; + +sub run_httpd { + my ($ipv6, $ssl) = @_; + return undef if $ssl && !$has_http_daemon_ssl; + return undef if $ipv6 && (!$ipv6_supported || !$http_daemon_supports_ipv6); + my $httpd = ddclient::Test::Fake::HTTPD->new( + host => $ipv6 ? '::1' : '127.0.0.1', + scheme => $ssl ? 'https' : 'http', + daemon_args => { + SSL_cert_file => "$certdir/dummy-server-cert.pem", + SSL_key_file => "$certdir/dummy-server-key.pem", + V6Only => 1, + }, + ); + $httpd->run(sub { + # Echo back the full request. + return [200, ['Content-Type' => 'application/octet-stream'], [$_[0]->as_string()]]; + }); + diag(sprintf("started IPv%s%s server running at %s", + $ipv6 ? '6' : '4', $ssl ? ' SSL' : '', $httpd->endpoint())); + return $httpd; +} + +my %httpd = ( + '4' => {'http' => run_httpd(0, 0), 'https' => run_httpd(0, 1)}, + '6' => {'http' => run_httpd(1, 0), 'https' => run_httpd(1, 1)}, +); + +my @test_cases = ( + # Fetch via IO::Socket::INET + {ipv6_opt => 0, server_ipv => '4', client_ipv => ''}, + {ipv6_opt => 0, server_ipv => '4', client_ipv => '4'}, + # IPv* client to a non-SSL IPv6 server is not expected to work unless opt('ipv6') is true + {ipv6_opt => 0, server_ipv => '6', client_ipv => '6'}, + + # Fetch via IO::Socket::INET6 + {ipv6_opt => 1, server_ipv => '4', client_ipv => ''}, + {ipv6_opt => 1, server_ipv => '4', client_ipv => '4'}, + {ipv6_opt => 1, server_ipv => '6', client_ipv => ''}, + {ipv6_opt => 1, server_ipv => '6', client_ipv => '6'}, + + # Fetch via IO::Socket::SSL + {ssl => 1, server_ipv => '4', client_ipv => ''}, + {ssl => 1, server_ipv => '4', client_ipv => '4'}, + {ssl => 1, server_ipv => '6', client_ipv => ''}, + {ssl => 1, server_ipv => '6', client_ipv => '6'}, + + # Fetch with curl + { curl => 1, server_ipv => '4', client_ipv => '' }, + { curl => 1, server_ipv => '4', client_ipv => '4' }, + { curl => 1, server_ipv => '6', client_ipv => '' }, + { curl => 1, server_ipv => '6', client_ipv => '6' }, + + # Fetch with curl and ssl + { curl => 1, ssl => 1, server_ipv => '4', client_ipv => '' }, + { curl => 1, ssl => 1, server_ipv => '4', client_ipv => '4' }, + { curl => 1, ssl => 1, server_ipv => '6', client_ipv => '' }, + { curl => 1, ssl => 1, server_ipv => '6', client_ipv => '6' }, +); + +for my $tc (@test_cases) { + $tc->{ipv6_opt} //= 0; + $tc->{ssl} //= 0; + $tc->{curl} //= 0; + SKIP: { + skip("IO::Socket::INET6 not available", 1) + if ($tc->{ipv6_opt} || $tc->{client_ipv} eq '6') && !$tc->{curl} && !$has_io_socket_inet6; + skip("IPv6 not supported on this system", 1) + if $tc->{server_ipv} eq '6' && !$ipv6_supported; + skip("HTTP::Daemon too old for IPv6 support", 1) + if $tc->{server_ipv} eq '6' && !$http_daemon_supports_ipv6; + skip("HTTP::Daemon::SSL not available", 1) if $tc->{ssl} && !$has_http_daemon_ssl; + skip("Curl not available on this system", 1) if $tc->{curl} && !$has_curl; + my $uri = $httpd{$tc->{server_ipv}}{$tc->{ssl} ? 'https' : 'http'}->endpoint(); + my $name = sprintf("IPv%s client to %s%s%s", + $tc->{client_ipv} || '*', $uri, $tc->{ipv6_opt} ? ' (-ipv6)' : '', + $tc->{curl} ? ' (curl)' : ''); + $ddclient::globals{'ipv6'} = $tc->{ipv6_opt}; + $ddclient::globals{'curl'} = $tc->{curl}; + my $got = ddclient::geturl(url => $uri, ipversion => $tc->{client_ipv}); + isnt($got // '', '', $name); + } +} + +done_testing(); diff -Nru ddclient-3.9.1/t/geturl_ssl.pl ddclient-3.10.0/t/geturl_ssl.pl --- ddclient-3.9.1/t/geturl_ssl.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/geturl_ssl.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,264 @@ +use Test::More; +use Data::Dumper; +eval { + require HTTP::Request; + require HTTP::Response; + require IO::Socket::IP; + require IO::Socket::SSL; + require ddclient::Test::Fake::HTTPD; +} or plan(skip_all => $@); +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +$Data::Dumper::Sortkeys = 1; + +my $httpd = ddclient::Test::Fake::HTTPD->new(); +$httpd->run(sub { + my $req = shift; + # Echo back the full request. + my $resp = [ 200, [ 'Content-Type' => 'application/octet-stream' ], [ $req->as_string() ] ]; + if ($req->method() ne 'GET') { + # TODO: Add support for CONNECT to test https via proxy. + $resp->[0] = 501; # 501 == Not Implemented + } + return $resp; +}); + +my $args; + +{ + package InterceptSocket; + require base; + base->import(qw(IO::Socket::IP)); + + sub new { + my ($class, %args) = @_; + $args = \%args; + return $class->SUPER::new(%args, PeerAddr => $httpd->host(), PeerPort => $httpd->port()); + } +} + +# Keys: +# * name: Display name. +# * params: Parameters to pass to geturl. +# * opt_ssl: Value to return from opt('ssl'). Defaults to 0. +# * opt_ssl_ca_dir: Value to return from opt('ssl_ca_dir'). Defaults to undef. +# * opt_ssl_ca_file: Value to return from opt('ssl_ca_file'). Defaults to undef. +# * want_args: Args that should be passed to the socket constructor minus MultiHomed, Proto, +# Timeout, and original_socket_class. +# * want_req_method: The HTTP method geturl is expected to use. Defaults to 'GET'. +# * want_req_uri: URI that geturl is expected to request. +# * todo: If defined, mark this test as expected to fail. +my @test_cases = ( + { + name => 'https', + params => { + url => 'https://hostname', + }, + want_args => { + PeerAddr => 'hostname', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'http with ssl=true', + params => { + url => 'http://hostname', + }, + opt_ssl => 1, + want_args => { + PeerAddr => 'hostname', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'https with port', + params => { + url => 'https://hostname:123', + }, + want_args => { + PeerAddr => 'hostname', + PeerPort => '123', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'http with port and ssl=true', + params => { + url => 'https://hostname:123', + }, + opt_ssl => 1, + want_args => { + PeerAddr => 'hostname', + PeerPort => '123', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'https proxy, http URL', + params => { + proxy => 'https://proxy', + url => 'http://hostname', + }, + want_args => { + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => 'http://hostname/', + todo => "broken", + }, + { + name => 'http proxy, https URL', + params => { + proxy => 'http://proxy', + url => 'https://hostname', + }, + want_args => { + PeerAddr => 'proxy', + PeerPort => '80', + SSL_startHandshake => 0, + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', + todo => "not yet supported; silently fails", + }, + { + name => 'https proxy, https URL', + params => { + proxy => 'https://proxy', + url => 'https://hostname', + }, + want_args => { + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', + todo => "not yet supported; silently fails", + }, + { + name => 'http proxy, http URL, ssl=true', + params => { + proxy => 'http://proxy', + url => 'http://hostname', + }, + opt_ssl => 1, + want_args => { + PeerAddr => 'proxy', + PeerPort => '443', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:443', + todo => "not yet supported; silently fails", + }, + { + name => 'https proxy with port, http URL with port', + params => { + proxy => 'https://proxy:123', + url => 'http://hostname:456', + }, + want_args => { + PeerAddr => 'proxy', + PeerPort => '123', + }, + want_req_uri => 'http://hostname:456/', + todo => "broken", + }, + { + name => 'http proxy with port, https URL with port', + params => { + proxy => 'http://proxy:123', + url => 'https://hostname:456', + }, + want_args => { + PeerAddr => 'proxy', + PeerPort => '123', + SSL_startHandshake => 0, + }, + want_req_method => 'CONNECT', + want_req_uri => 'hostname:456', + todo => "not yet supported; silently fails", + }, + { + name => 'CA dir', + params => { + url => 'https://hostname', + }, + opt_ssl_ca_dir => '/ca/dir', + want_args => { + PeerAddr => 'hostname', + PeerPort => '443', + SSL_ca_path => '/ca/dir', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'CA file', + params => { + url => 'https://hostname', + }, + opt_ssl_ca_file => '/ca/file', + want_args => { + PeerAddr => 'hostname', + PeerPort => '443', + SSL_ca_file => '/ca/file', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, + { + name => 'CA dir and file', + params => { + url => 'https://hostname', + }, + opt_ssl_ca_dir => '/ca/dir', + opt_ssl_ca_file => '/ca/file', + want_args => { + PeerAddr => 'hostname', + PeerPort => '443', + SSL_ca_file => '/ca/file', + SSL_ca_path => '/ca/dir', + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + }, + want_req_uri => '/', + }, +); + +for my $tc (@test_cases) { + $args = undef; + $ddclient::globals{'ssl'} = $tc->{opt_ssl} // 0; + $ddclient::globals{'ssl_ca_dir'} = $tc->{opt_ssl_ca_dir}; + $ddclient::globals{'ssl_ca_file'} = $tc->{opt_ssl_ca_file}; + my $resp_str = ddclient::geturl(_testonly_socket_class => 'InterceptSocket', %{$tc->{params}}); + TODO: { + local $TODO = $tc->{todo}; + subtest $tc->{name} => sub { + my %want_args = ( + MultiHomed => 1, + Proto => 'tcp', + Timeout => ddclient::opt('timeout'), + original_socket_class => 'IO::Socket::SSL', + %{$tc->{want_args}}, + ); + is(Dumper($args), Dumper(\%want_args), "socket constructor args"); + ok(defined($resp_str), "response is defined") or return; + ok(my $resp = HTTP::Response->parse($resp_str), "parse response") or return; + ok(my $req_str = $resp->decoded_content(), "decode request from response") or return; + ok(my $req = HTTP::Request->parse($req_str), "parse request") or return; + is($req->method(), $tc->{want_req_method} // 'GET', "request method"); + is($req->uri(), $tc->{want_req_uri}, "request URI"); + }; + } +} + +done_testing(); diff -Nru ddclient-3.9.1/t/is-and-extract-ipv4.pl ddclient-3.10.0/t/is-and-extract-ipv4.pl --- ddclient-3.9.1/t/is-and-extract-ipv4.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/is-and-extract-ipv4.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,83 @@ +use Test::More; +use B qw(perlstring); + +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + + +my @valid_ipv4 = ( + "192.168.1.1", + "0.0.0.0", + "000.000.000.000", + "255.255.255.255", + "10.0.0.0", +); + +my @invalid_ipv4 = ( + undef, + "", + "192.168.1", + "0.0.0", + "000.000", + "256.256.256.256", + ".10.0.0.0", +); + + +subtest "is_ipv4() with valid addresses" => sub { + foreach my $ip (@valid_ipv4) { + ok(ddclient::is_ipv4($ip), "is_ipv4('$ip')"); + } +}; + +subtest "is_ipv4() with invalid addresses" => sub { + foreach my $ip (@invalid_ipv4) { + ok(!ddclient::is_ipv4($ip), sprintf("!is_ipv4(%s)", defined($ip) ? "'$ip'" : 'undef')); + } +}; + +subtest "is_ipv4() with char adjacent to valid address" => sub { + foreach my $ch (split(//, '/.,:z @$#&%!^*()_-+'), "\n") { + subtest perlstring($ch) => sub { + foreach my $ip (@valid_ipv4) { + subtest $ip => sub { + my $test = $ch . $ip; # insert at front + ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); + $test = $ip . $ch; # add at end + ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); + $test = $ch . $ip . $ch; # wrap front and end + ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); + }; + } + }; + } +}; + +subtest "extract_ipv4()" => sub { + my @test_cases = ( + {name => "undef", text => undef, want => undef}, + {name => "empty", text => "", want => undef}, + {name => "invalid", text => "1.2.3.256", want => undef}, + {name => "two addrs", text => "1.1.1.1\n2.2.2.2", want => "1.1.1.1"}, + {name => "host+port", text => "1.2.3.4:123", want => "1.2.3.4"}, + {name => "zero pad", text => "001.002.003.004", want => "1.2.3.4"}, + ); + foreach my $tc (@test_cases) { + is(ddclient::extract_ipv4($tc->{text}), $tc->{want}, $tc->{name}); + } +}; + +subtest "extract_ipv4() of valid addr with adjacent non-word char" => sub { + foreach my $wb (split(//, '/, @$#&%!^*()_-+:'), "\n") { + subtest perlstring($wb) => sub { + my $test = ""; + foreach my $ip (@valid_ipv4) { + $test = "foo" . $wb . $ip . $wb . "bar"; # wrap front and end + $ip =~ s/\b0+\B//g; ## remove embedded leading zeros for testing + is(ddclient::extract_ipv4($test), $ip, perlstring($test)); + } + }; + } +}; + +done_testing(); diff -Nru ddclient-3.9.1/t/is-and-extract-ipv6-global.pl ddclient-3.10.0/t/is-and-extract-ipv6-global.pl --- ddclient-3.9.1/t/is-and-extract-ipv6-global.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/is-and-extract-ipv6-global.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,66 @@ +use Test::More; +use ddclient::t; +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +subtest "is_ipv6_global() with valid but non-globally-routable addresses" => sub { + foreach my $ip ( + # The entirety of ::/16 is assumed to never contain globally routable addresses + "::", + "::1", + "0:ffff:ffff:ffff:ffff:ffff:ffff:ffff", + # fc00::/7 unique local addresses (ULA) + "fc00::", + "fdff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", + # fe80::/10 link-local unicast addresses + "fe80::", + "febf:ffff:ffff:ffff:ffff:ffff:ffff:ffff", + # ff00::/8 multicast addresses + "ff00::", + "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", + # Case insensitivity of the negative lookahead + "FF00::", + ) { + ok(!ddclient::is_ipv6_global($ip), "!is_ipv6_global('$ip')"); + } +}; + +subtest "is_ipv6_global() with valid, globally routable addresses" => sub { + foreach my $ip ( + "1::", # just after ::/16 assumed non-global block + "fbff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before fc00::/7 ULA block + "fe00::", # just after fc00::/7 ULA block + "fe7f:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before fe80::/10 link-local block + "fec0::", # just after fe80::/10 link-local block + "feff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before ff00::/8 multicast block + ) { + ok(ddclient::is_ipv6_global($ip), "is_ipv6_global('$ip')"); + } +}; + +subtest "extract_ipv6_global()" => sub { + my @test_cases = ( + {name => "undef", text => undef, want => undef}, + {name => "empty", text => "", want => undef}, + {name => "only non-global", text => "foo fe80:: bar", want => undef}, + {name => "single global", text => "foo 2000:: bar", want => "2000::"}, + {name => "multiple globals", text => "2000:: 3000::", want => "2000::"}, + {name => "global before non-global", text => "2000:: fe80::", want => "2000::"}, + {name => "non-global before global", text => "fe80:: 2000::", want => "2000::"}, + {name => "zero pad", text => "2001::0001", want => "2001::1"}, + ); + foreach my $tc (@test_cases) { + is(ddclient::extract_ipv6_global($tc->{text}), $tc->{want}, $tc->{name}); + } +}; + +subtest "interface config samples" => sub { + for my $sample (@ddclient::t::interface_samples) { + if (defined($sample->{want_extract_ipv6_global})) { + my $got = ddclient::extract_ipv6_global($sample->{text}); + is($got, $sample->{want_extract_ipv6_global}, $sample->{name}); + } + } +}; + +done_testing(); diff -Nru ddclient-3.9.1/t/is-and-extract-ipv6.pl ddclient-3.10.0/t/is-and-extract-ipv6.pl --- ddclient-3.9.1/t/is-and-extract-ipv6.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/is-and-extract-ipv6.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,441 @@ +use Test::More; +use B qw(perlstring); +use ddclient::t; +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + + +my @valid_ipv6 = ( + "::abcd:efAB:CDEF", # case sensitivity + "08:09:0a:0b:0c:0d:0e:0f", # leading zeros + + # with thanks to http://home.deds.nl/~aeron/regex/valid_ipv6.txt + "1111:2222:3333:4444:5555:6666:7777:8888", + "1111:2222:3333:4444:5555:6666:7777::", + "1111:2222:3333:4444:5555:6666::", + "1111:2222:3333:4444:5555::", + "1111:2222:3333:4444::", + "1111:2222:3333::", + "1111:2222::", + "1111::", + "::", + "1111:2222:3333:4444:5555:6666::8888", + "1111:2222:3333:4444:5555::8888", + "1111:2222:3333:4444::8888", + "1111:2222:3333::8888", + "1111:2222::8888", + "1111::8888", + "::8888", + "1111:2222:3333:4444:5555::7777:8888", + "1111:2222:3333:4444::7777:8888", + "1111:2222:3333::7777:8888", + "1111:2222::7777:8888", + "1111::7777:8888", + "::7777:8888", + "1111:2222:3333:4444::6666:7777:8888", + "1111:2222:3333::6666:7777:8888", + "1111:2222::6666:7777:8888", + "1111::6666:7777:8888", + "::6666:7777:8888", + "1111:2222:3333::5555:6666:7777:8888", + "1111:2222::5555:6666:7777:8888", + "1111::5555:6666:7777:8888", + "::5555:6666:7777:8888", + "1111:2222::4444:5555:6666:7777:8888", + "1111::4444:5555:6666:7777:8888", + "::4444:5555:6666:7777:8888", + "1111::3333:4444:5555:6666:7777:8888", + "::3333:4444:5555:6666:7777:8888", + "::2222:3333:4444:5555:6666:7777:8888", + # IPv4-mapped IPv6 addresses + "1111:2222:3333:4444:5555:6666:0.0.0.0", + "1111:2222:3333:4444:5555:6666:00.00.00.00", + "1111:2222:3333:4444:5555:6666:000.000.000.000", + "1111:2222:3333:4444:5555:6666:123.123.123.123", + "1111:2222:3333:4444:5555::123.123.123.123", + "1111:2222:3333:4444::123.123.123.123", + "1111:2222:3333::123.123.123.123", + "1111:2222::123.123.123.123", + "1111::123.123.123.123", + "::123.123.123.123", + "1111:2222:3333:4444::6666:123.123.123.123", + "1111:2222:3333::6666:123.123.123.123", + "1111:2222::6666:123.123.123.123", + "1111::6666:123.123.123.123", + "::6666:123.123.123.123", + "1111:2222:3333::5555:6666:123.123.123.123", + "1111:2222::5555:6666:123.123.123.123", + "1111::5555:6666:123.123.123.123", + "::5555:6666:123.123.123.123", + "1111:2222::4444:5555:6666:123.123.123.123", + "1111::4444:5555:6666:123.123.123.123", + "::4444:5555:6666:123.123.123.123", + "1111::3333:4444:5555:6666:123.123.123.123", + "::3333:4444:5555:6666:123.123.123.123", + "::2222:3333:4444:5555:6666:123.123.123.123", +); + +my @invalid_ipv6 = ( + # Empty string and bogus text + undef, + "", + " ", + "foobar", + + # Valid IPv6 with extra text before or after + "foo2001:DB8:4341:0781:1111:2222:3333:4444", + "foo 2001:DB8:4341:0781::4444", + "foo 2001:DB8:4341:0781:1111:: bar", + "foo2001:DB8:4341:0781::100bar", + "2001:DB8:4341:0781::1 bar", + "2001:DB8:4341:0781::0001bar", + "foo bar 3001:DB8:4341:0781:1111:2222:3333:4444 foo bar", + "__3001:DB8:4341:0781::4444", + "__3001:DB8:4341:0781:1111::__", + "--3001:DB8:4341:0781::100--", + "/3001:DB8:4341:0781::1/", + "3001:DB8:4341:0781::0001%", + "fdb6:1d86:d9bd:1::4444%eth0", + "fdb6:1d86:d9bd:1:1111::%ens192", + "fdb6:1d86:d9bd:1::100%en0", + "fdb6:1d86:d9bd:1::1%eth1.100", + + # With thanks to http://home.deds.nl/~aeron/regex/invalid_ipv6.txt + # Invalid data + "XXXX:XXXX:XXXX:XXXX:XXXX:XXXX:XXXX:XXXX", + + # Too many components + "1111:2222:3333:4444:5555:6666:7777:8888:9999", + "1111:2222:3333:4444:5555:6666:7777:8888::", + "::2222:3333:4444:5555:6666:7777:8888:9999", + + # Too few components + "1111:2222:3333:4444:5555:6666:7777", + "1111:2222:3333:4444:5555:6666", + "1111:2222:3333:4444:5555", + "1111:2222:3333:4444", + "1111:2222:3333", + "1111:2222", + "1111", + + # Missing : + "11112222:3333:4444:5555:6666:7777:8888", + "1111:22223333:4444:5555:6666:7777:8888", + "1111:2222:33334444:5555:6666:7777:8888", + "1111:2222:3333:44445555:6666:7777:8888", + "1111:2222:3333:4444:55556666:7777:8888", + "1111:2222:3333:4444:5555:66667777:8888", + "1111:2222:3333:4444:5555:6666:77778888", + + # Missing : intended for :: + "1111:2222:3333:4444:5555:6666:7777:8888:", + "1111:2222:3333:4444:5555:6666:7777:", + "1111:2222:3333:4444:5555:6666:", + "1111:2222:3333:4444:5555:", + "1111:2222:3333:4444:", + "1111:2222:3333:", + "1111:2222:", + "1111:", + ":", + ":8888", + ":7777:8888", + ":6666:7777:8888", + ":5555:6666:7777:8888", + ":4444:5555:6666:7777:8888", + ":3333:4444:5555:6666:7777:8888", + ":2222:3333:4444:5555:6666:7777:8888", + ":1111:2222:3333:4444:5555:6666:7777:8888", + + # ::: + ":::2222:3333:4444:5555:6666:7777:8888", + "1111:::3333:4444:5555:6666:7777:8888", + "1111:2222:::4444:5555:6666:7777:8888", + "1111:2222:3333:::5555:6666:7777:8888", + "1111:2222:3333:4444:::6666:7777:8888", + "1111:2222:3333:4444:5555:::7777:8888", + "1111:2222:3333:4444:5555:6666:::8888", + "1111:2222:3333:4444:5555:6666:7777:::", + + # Double :: + "::2222::4444:5555:6666:7777:8888", + "::2222:3333::5555:6666:7777:8888", + "::2222:3333:4444::6666:7777:8888", + "::2222:3333:4444:5555::7777:8888", + "::2222:3333:4444:5555:7777::8888", + "::2222:3333:4444:5555:7777:8888::", + + "1111::3333::5555:6666:7777:8888", + "1111::3333:4444::6666:7777:8888", + "1111::3333:4444:5555::7777:8888", + "1111::3333:4444:5555:6666::8888", + "1111::3333:4444:5555:6666:7777::", + + "1111:2222::4444::6666:7777:8888", + "1111:2222::4444:5555::7777:8888", + "1111:2222::4444:5555:6666::8888", + "1111:2222::4444:5555:6666:7777::", + + "1111:2222:3333::5555::7777:8888", + "1111:2222:3333::5555:6666::8888", + "1111:2222:3333::5555:6666:7777::", + + "1111:2222:3333:4444::6666::8888", + "1111:2222:3333:4444::6666:7777::", + + "1111:2222:3333:4444:5555::7777::", + + # Invalid data + "XXXX:XXXX:XXXX:XXXX:XXXX:XXXX:1.2.3.4", + "1111:2222:3333:4444:5555:6666:256.256.256.256", + + # Too many components + "1111:2222:3333:4444:5555:6666:7777:8888:1.2.3", + "1111:2222:3333:4444:5555:6666:7777:1.2.3.4", + "1111:2222:3333:4444:5555:6666::1.2.3.4", + "::2222:3333:4444:5555:6666:7777:1.2.3.4", + "1111:2222:3333:4444:5555:6666:1.2.3.4.5", + + # Too few components + "1111:2222:3333:4444:5555:1.2.3.4", + "1111:2222:3333:4444:1.2.3.4", + "1111:2222:3333:1.2.3.4", + "1111:2222:1.2.3.4", + "1111:1.2.3.4", + "1.2.3.4", + + # Missing : + "11112222:3333:4444:5555:6666:1.2.3.4", + "1111:22223333:4444:5555:6666:1.2.3.4", + "1111:2222:33334444:5555:6666:1.2.3.4", + "1111:2222:3333:44445555:6666:1.2.3.4", + "1111:2222:3333:4444:55556666:1.2.3.4", + "1111:2222:3333:4444:5555:66661.2.3.4", + + # Missing . + "1111:2222:3333:4444:5555:6666:255255.255.255", + "1111:2222:3333:4444:5555:6666:255.255255.255", + "1111:2222:3333:4444:5555:6666:255.255.255255", + + # Missing : intended for :: + ":1.2.3.4", + ":6666:1.2.3.4", + ":5555:6666:1.2.3.4", + ":4444:5555:6666:1.2.3.4", + ":3333:4444:5555:6666:1.2.3.4", + ":2222:3333:4444:5555:6666:1.2.3.4", + ":1111:2222:3333:4444:5555:6666:1.2.3.4", + + # ::: + ":::2222:3333:4444:5555:6666:1.2.3.4", + "1111:::3333:4444:5555:6666:1.2.3.4", + "1111:2222:::4444:5555:6666:1.2.3.4", + "1111:2222:3333:::5555:6666:1.2.3.4", + "1111:2222:3333:4444:::6666:1.2.3.4", + "1111:2222:3333:4444:5555:::1.2.3.4", + + # Double :: + "::2222::4444:5555:6666:1.2.3.4", + "::2222:3333::5555:6666:1.2.3.4", + "::2222:3333:4444::6666:1.2.3.4", + "::2222:3333:4444:5555::1.2.3.4", + + "1111::3333::5555:6666:1.2.3.4", + "1111::3333:4444::6666:1.2.3.4", + "1111::3333:4444:5555::1.2.3.4", + + "1111:2222::4444::6666:1.2.3.4", + "1111:2222::4444:5555::1.2.3.4", + + "1111:2222:3333::5555::1.2.3.4", + + # Missing parts + "::.", + "::..", + "::...", + "::1...", + "::1.2..", + "::1.2.3.", + "::.2..", + "::.2.3.", + "::.2.3.4", + "::..3.", + "::..3.4", + "::...4", + + # Extra : in front + ":1111:2222:3333:4444:5555:6666:7777::", + ":1111:2222:3333:4444:5555:6666::", + ":1111:2222:3333:4444:5555::", + ":1111:2222:3333:4444::", + ":1111:2222:3333::", + ":1111:2222::", + ":1111::", + ":::", + ":1111:2222:3333:4444:5555:6666::8888", + ":1111:2222:3333:4444:5555::8888", + ":1111:2222:3333:4444::8888", + ":1111:2222:3333::8888", + ":1111:2222::8888", + ":1111::8888", + ":::8888", + ":1111:2222:3333:4444:5555::7777:8888", + ":1111:2222:3333:4444::7777:8888", + ":1111:2222:3333::7777:8888", + ":1111:2222::7777:8888", + ":1111::7777:8888", + ":::7777:8888", + ":1111:2222:3333:4444::6666:7777:8888", + ":1111:2222:3333::6666:7777:8888", + ":1111:2222::6666:7777:8888", + ":1111::6666:7777:8888", + ":::6666:7777:8888", + ":1111:2222:3333::5555:6666:7777:8888", + ":1111:2222::5555:6666:7777:8888", + ":1111::5555:6666:7777:8888", + ":::5555:6666:7777:8888", + ":1111:2222::4444:5555:6666:7777:8888", + ":1111::4444:5555:6666:7777:8888", + ":::4444:5555:6666:7777:8888", + ":1111::3333:4444:5555:6666:7777:8888", + ":::3333:4444:5555:6666:7777:8888", + ":::2222:3333:4444:5555:6666:7777:8888", + ":1111:2222:3333:4444:5555:6666:1.2.3.4", + ":1111:2222:3333:4444:5555::1.2.3.4", + ":1111:2222:3333:4444::1.2.3.4", + ":1111:2222:3333::1.2.3.4", + ":1111:2222::1.2.3.4", + ":1111::1.2.3.4", + ":::1.2.3.4", + ":1111:2222:3333:4444::6666:1.2.3.4", + ":1111:2222:3333::6666:1.2.3.4", + ":1111:2222::6666:1.2.3.4", + ":1111::6666:1.2.3.4", + ":::6666:1.2.3.4", + ":1111:2222:3333::5555:6666:1.2.3.4", + ":1111:2222::5555:6666:1.2.3.4", + ":1111::5555:6666:1.2.3.4", + ":::5555:6666:1.2.3.4", + ":1111:2222::4444:5555:6666:1.2.3.4", + ":1111::4444:5555:6666:1.2.3.4", + ":::4444:5555:6666:1.2.3.4", + ":1111::3333:4444:5555:6666:1.2.3.4", + ":::3333:4444:5555:6666:1.2.3.4", + ":::2222:3333:4444:5555:6666:1.2.3.4", + + # Extra : at end + "1111:2222:3333:4444:5555:6666:7777:::", + "1111:2222:3333:4444:5555:6666:::", + "1111:2222:3333:4444:5555:::", + "1111:2222:3333:4444:::", + "1111:2222:3333:::", + "1111:2222:::", + "1111:::", + ":::", + "1111:2222:3333:4444:5555:6666::8888:", + "1111:2222:3333:4444:5555::8888:", + "1111:2222:3333:4444::8888:", + "1111:2222:3333::8888:", + "1111:2222::8888:", + "1111::8888:", + "::8888:", + "1111:2222:3333:4444:5555::7777:8888:", + "1111:2222:3333:4444::7777:8888:", + "1111:2222:3333::7777:8888:", + "1111:2222::7777:8888:", + "1111::7777:8888:", + "::7777:8888:", + "1111:2222:3333:4444::6666:7777:8888:", + "1111:2222:3333::6666:7777:8888:", + "1111:2222::6666:7777:8888:", + "1111::6666:7777:8888:", + "::6666:7777:8888:", + "1111:2222:3333::5555:6666:7777:8888:", + "1111:2222::5555:6666:7777:8888:", + "1111::5555:6666:7777:8888:", + "::5555:6666:7777:8888:", + "1111:2222::4444:5555:6666:7777:8888:", + "1111::4444:5555:6666:7777:8888:", + "::4444:5555:6666:7777:8888:", + "1111::3333:4444:5555:6666:7777:8888:", + "::3333:4444:5555:6666:7777:8888:", + "::2222:3333:4444:5555:6666:7777:8888:", +); + + +subtest "is_ipv6() with valid addresses" => sub { + foreach my $ip (@valid_ipv6) { + ok(ddclient::is_ipv6($ip), "is_ipv6('$ip')"); + } +}; + +subtest "is_ipv6() with invalid addresses" => sub { + foreach my $ip (@invalid_ipv6) { + ok(!ddclient::is_ipv6($ip), sprintf("!is_ipv6(%s)", defined($ip) ? "'$ip'" : 'undef')); + } +}; + +subtest "is_ipv6() with char adjacent to valid address" => sub { + foreach my $ch (split(//, '/.,:z @$#&%!^*()_-+'), "\n") { + subtest perlstring($ch) => sub { + foreach my $ip (@valid_ipv6) { + subtest $ip => sub { + my $test = $ch . $ip; # insert at front + ok(!ddclient::is_ipv6($test), "!is_ipv6('$test')"); + $test = $ip . $ch; # add at end + ok(!ddclient::is_ipv6($test), "!is_ipv6('$test')"); + $test = $ch . $ip . $ch; # wrap front and end + ok(!ddclient::is_ipv6($test), "!is_ipv6('$test')"); + }; + } + }; + } +}; + +subtest "extract_ipv6()" => sub { + my @test_cases = ( + {name => "undef", text => undef, want => undef}, + {name => "empty", text => "", want => undef}, + {name => "invalid", text => "::12345", want => undef}, + {name => "two addrs", text => "::1\n::2", want => "::1"}, + {name => "zone index", text => "fe80::1%0", want => "fe80::1"}, + {name => "url host+port", text => "[::1]:123", want => "::1"}, + {name => "url host+zi+port", text => "[fe80::1%250]:123", want => "fe80::1"}, + {name => "zero pad", text => "::0001", want => "::1"}, + ); + foreach my $tc (@test_cases) { + is(ddclient::extract_ipv6($tc->{text}), $tc->{want}, $tc->{name}); + } +}; + +subtest "extract_ipv6() of valid addr with adjacent non-word char" => sub { + foreach my $wb (split(//, '/, @$#&%!^*()_-+'), "\n") { + subtest perlstring($wb) => sub { + my $test = ""; + foreach my $ip (@valid_ipv6) { + $test = "foo" . $wb . $ip . $wb . "bar"; # wrap front and end + $ip =~ s/\b0+\B//g; ## remove embedded leading zeros for testing + is(ddclient::extract_ipv6($test), $ip, perlstring($test)); + } + }; + } +}; + +subtest "interface config samples" => sub { + for my $sample (@ddclient::t::interface_samples) { + if (defined($sample->{want_extract_ipv6_global})) { + subtest $sample->{name} => sub { + my $ip = ddclient::extract_ipv6($sample->{text}); + ok(ddclient::is_ipv6($ip), "extract_ipv6() returns an IPv6 address"); + }; + foreach my $line (split(/\n/, $sample->{text})) { + my $ip = ddclient::extract_ipv6($line); + if ($ip) { ## Test cases may have lines that do not contain IPv6 address. + ok(ddclient::is_ipv6($ip), + sprintf("extract_ipv6(%s) returns an IPv6 address", perlstring($line))); + } + } + } + } +}; + +done_testing(); diff -Nru ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem --- ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,80 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + 11:82:5d:80:30:4c:a9:6d:ed:68:88:10:c8:90:4d:08:50:3c:4c:b0 + Signature Algorithm: sha256WithRSAEncryption + Issuer: CN=Root Certification Authority + Validity + Not Before: Jul 3 19:47:44 2020 GMT + Not After : Jul 4 19:47:44 2120 GMT + Subject: CN=Root Certification Authority + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + RSA Public-Key: (2048 bit) + Modulus: + 00:c5:f2:d9:a9:48:a2:06:dc:89:7d:e8:ab:2e:1f: + 70:ea:da:82:46:45:4e:42:38:6e:8d:a6:3e:28:84: + f1:25:c0:ea:25:af:61:ca:87:38:a5:7b:3f:d0:3a: + 57:82:c7:eb:f1:b5:b4:70:0e:71:69:22:5f:ae:49: + d3:51:df:19:97:bf:00:c3:de:99:3a:4d:f3:6d:4a: + bf:73:7e:b1:aa:72:40:b1:0d:fc:d4:af:11:f5:a9: + 7e:c3:36:7a:ac:25:86:a4:3e:7a:fe:3f:0f:22:f7: + d6:87:15:ba:33:c1:36:c3:79:4d:79:b3:ca:a5:2d: + 15:9a:63:ad:38:32:99:74:76:d7:72:7e:2f:69:ff: + 7b:b0:f6:79:ad:da:2d:9f:51:4e:d9:70:15:9c:83: + e9:10:8c:ec:7f:39:27:5d:b9:6e:86:c9:93:54:6b: + aa:82:12:82:b0:32:36:c5:94:6c:48:bb:3f:c6:af: + ef:1c:e1:0c:18:e6:0c:4c:bf:58:67:5b:1a:cd:15: + 62:37:40:40:5f:1d:76:e2:24:01:28:65:cc:ed:3f: + e1:f1:08:79:94:12:13:4c:4c:e2:a4:53:b8:fe:78: + 7f:07:00:cd:c1:3a:7b:0e:f4:35:ce:83:c7:f3:ce: + 71:9d:1f:7b:88:66:bc:b6:39:5e:26:28:e5:ef:5a: + 0d:05 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C + X509v3 Authority Key Identifier: + keyid:21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C + + X509v3 Basic Constraints: critical + CA:TRUE + X509v3 Key Usage: critical + Certificate Sign, CRL Sign + Signature Algorithm: sha256WithRSAEncryption + 9d:4c:17:84:f3:83:90:97:a7:df:e5:af:53:ac:d7:75:94:c4: + a0:29:fa:d7:8f:a6:f8:fa:4b:d6:5e:d2:6e:8d:6d:46:89:1f: + 7b:30:2c:2d:d3:3b:b6:64:1d:ec:ad:60:c1:96:4b:9a:bc:f9: + d0:5d:af:a1:73:f7:03:99:8a:e2:59:47:48:1c:8f:7a:99:97: + 20:78:e2:16:16:e4:c3:c9:82:4e:25:58:23:75:c9:9c:71:67: + 8e:c4:79:e1:b9:ac:d9:c2:51:41:3d:a6:bf:07:0b:4b:14:8c: + ca:42:0f:c3:b7:71:c0:fb:3e:5e:de:2b:e5:7f:92:52:50:12: + 4f:63:a5:fa:3b:63:59:fa:37:3f:42:f4:ec:13:a0:c7:5d:0c: + 9c:cd:6b:32:96:e7:44:da:5f:8c:cf:c7:51:eb:81:3b:cc:e8: + 39:41:0c:a1:bb:8f:3a:f8:b1:ee:2b:97:f4:13:c9:a8:9c:1c: + 2f:2f:51:57:e4:0c:4e:2b:29:7f:5e:12:72:63:8c:bb:40:2c: + 97:14:bf:1e:7a:66:bc:64:af:78:80:64:19:37:ca:7a:f3:de: + 15:e6:23:1d:d0:90:7d:e6:5f:21:88:23:c5:23:ca:f2:29:00: + 1d:9a:7a:58:37:6d:a9:9e:ab:24:b1:c6:c5:3b:46:11:a7:53: + 80:ef:aa:9c +-----BEGIN CERTIFICATE----- +MIIDQTCCAimgAwIBAgIUEYJdgDBMqW3taIgQyJBNCFA8TLAwDQYJKoZIhvcNAQEL +BQAwJzElMCMGA1UEAwwcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAgFw0y +MDA3MDMxOTQ3NDRaGA8yMTIwMDcwNDE5NDc0NFowJzElMCMGA1UEAwwcUm9vdCBD +ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC +AQoCggEBAMXy2alIogbciX3oqy4fcOragkZFTkI4bo2mPiiE8SXA6iWvYcqHOKV7 +P9A6V4LH6/G1tHAOcWkiX65J01HfGZe/AMPemTpN821Kv3N+sapyQLEN/NSvEfWp +fsM2eqwlhqQ+ev4/DyL31ocVujPBNsN5TXmzyqUtFZpjrTgymXR213J+L2n/e7D2 +ea3aLZ9RTtlwFZyD6RCM7H85J125bobJk1RrqoISgrAyNsWUbEi7P8av7xzhDBjm +DEy/WGdbGs0VYjdAQF8dduIkAShlzO0/4fEIeZQSE0xM4qRTuP54fwcAzcE6ew70 +Nc6Dx/POcZ0fe4hmvLY5XiYo5e9aDQUCAwEAAaNjMGEwHQYDVR0OBBYEFCHo3rbY +ZAFyAsUcyhYM2QUaFKEMMB8GA1UdIwQYMBaAFCHo3rbYZAFyAsUcyhYM2QUaFKEM +MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBCwUA +A4IBAQCdTBeE84OQl6ff5a9TrNd1lMSgKfrXj6b4+kvWXtJujW1GiR97MCwt0zu2 +ZB3srWDBlkuavPnQXa+hc/cDmYriWUdIHI96mZcgeOIWFuTDyYJOJVgjdcmccWeO +xHnhuazZwlFBPaa/BwtLFIzKQg/Dt3HA+z5e3ivlf5JSUBJPY6X6O2NZ+jc/QvTs +E6DHXQyczWsyludE2l+Mz8dR64E7zOg5QQyhu486+LHuK5f0E8monBwvL1FX5AxO +Kyl/XhJyY4y7QCyXFL8eema8ZK94gGQZN8p6894V5iMd0JB95l8hiCPFI8ryKQAd +mnpYN22pnqskscbFO0YRp1OA76qc +-----END CERTIFICATE----- diff -Nru ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem --- ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,165 @@ +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + 11:82:5d:80:30:4c:a9:6d:ed:68:88:10:c8:90:4d:08:50:3c:4c:b1 + Signature Algorithm: sha256WithRSAEncryption + Issuer: CN=Root Certification Authority + Validity + Not Before: Jul 3 19:47:44 2020 GMT + Not After : Jul 4 19:47:44 2120 GMT + Subject: CN=localhost + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + RSA Public-Key: (2048 bit) + Modulus: + 00:e7:3f:9a:d6:f8:4d:c3:89:69:1f:ab:95:00:b4: + 20:eb:36:72:e1:47:ba:0c:d8:20:76:9f:78:ec:f2: + d4:1c:2d:47:6c:79:a7:af:ce:e8:f6:91:c1:e8:f2: + 77:41:3b:37:70:36:13:f2:5b:30:45:eb:74:d0:f4: + 37:6e:20:d5:5a:aa:de:fc:df:72:b2:07:bb:da:1c: + 66:b7:72:20:cf:34:5f:55:f0:23:36:c3:9f:01:54: + 45:70:65:e5:2a:b3:03:b1:9e:73:dc:a2:32:cb:02: + e0:60:89:a5:f4:9a:87:e2:8a:bc:4d:80:1b:93:c2: + 61:d5:10:eb:ed:6c:fc:a0:b3:a5:22:3c:03:02:72: + e1:71:08:86:42:03:3a:0d:7b:6e:1c:f3:bb:3d:ad: + a8:e4:c2:3f:7c:0a:eb:bd:c1:89:1d:f1:bc:ed:43: + 7e:47:94:e0:f3:17:6d:13:96:be:af:74:e5:20:25: + 71:95:c5:7f:26:d2:28:a4:ee:bd:12:fe:04:e8:8b: + 46:da:7f:e1:fc:54:c0:dc:52:be:55:e2:49:25:ca: + 21:09:cf:e2:ed:e9:70:26:24:62:2e:89:6e:22:2d: + 8c:20:3d:83:f7:d1:b5:e1:74:1c:5d:b9:cb:b6:d5: + 60:93:06:96:1c:cc:b4:0a:4e:00:6a:04:d6:ba:2f: + ea:c7 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 72:14:A2:93:7E:96:27:D7:E9:F0:89:D7:53:52:11:11:D9:B5:5B:8B + X509v3 Authority Key Identifier: + keyid:21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C + + X509v3 Subject Alternative Name: + DNS:localhost, IP Address:127.0.0.1, IP Address:0:0:0:0:0:0:0:1 + X509v3 Basic Constraints: + CA:FALSE + X509v3 Key Usage: critical + Digital Signature, Key Encipherment + X509v3 Extended Key Usage: + TLS Web Server Authentication + Signature Algorithm: sha256WithRSAEncryption + 29:03:4e:91:19:6b:48:b4:09:89:fb:33:47:bf:43:97:57:f1: + 23:0a:e7:89:22:df:7b:05:97:cf:2c:3f:2f:26:2f:db:81:2e: + 88:40:97:ce:58:a5:c3:d0:78:08:2a:89:d7:a6:fd:87:9a:22: + 2b:82:e8:5e:f9:96:56:8b:09:7c:84:35:08:20:c5:1e:ba:fb: + 7f:aa:92:5d:2c:1e:6e:35:51:6d:8b:f4:de:ba:01:43:a0:7f: + e0:03:f8:94:5f:8a:c5:a9:4b:64:dd:64:ae:8e:79:d3:48:11: + 77:c4:78:a9:14:dc:08:29:76:bd:ea:9d:88:09:b4:95:9c:29: + 41:96:77:21:ce:a7:cb:ba:5b:05:38:bc:5b:06:63:24:f4:41: + 25:b3:4d:45:86:95:f1:8a:41:b4:4d:8a:20:70:b9:99:88:a6: + 96:93:b3:81:6d:80:06:49:29:47:fd:30:83:3f:e5:ef:52:97: + d2:92:fb:43:ba:fd:fe:15:bf:a3:84:55:e5:c9:db:3e:5f:00: + 14:28:3f:86:8e:72:65:cb:2c:e5:8e:75:39:14:e7:e5:82:92: + 6e:fb:3d:ab:40:1c:c9:f8:6c:bc:a4:b1:68:b5:8f:58:82:78: + a1:94:8e:c9:b7:fb:bb:bd:aa:cd:f5:0c:d9:00:70:fb:4f:ca: + 3d:d1:e7:6b +-----BEGIN CERTIFICATE----- +MIIDbTCCAlWgAwIBAgIUEYJdgDBMqW3taIgQyJBNCFA8TLEwDQYJKoZIhvcNAQEL +BQAwJzElMCMGA1UEAwwcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAgFw0y +MDA3MDMxOTQ3NDRaGA8yMTIwMDcwNDE5NDc0NFowFDESMBAGA1UEAwwJbG9jYWxo +b3N0MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA5z+a1vhNw4lpH6uV +ALQg6zZy4Ue6DNggdp947PLUHC1HbHmnr87o9pHB6PJ3QTs3cDYT8lswRet00PQ3 +biDVWqre/N9ysge72hxmt3IgzzRfVfAjNsOfAVRFcGXlKrMDsZ5z3KIyywLgYIml +9JqH4oq8TYAbk8Jh1RDr7Wz8oLOlIjwDAnLhcQiGQgM6DXtuHPO7Pa2o5MI/fArr +vcGJHfG87UN+R5Tg8xdtE5a+r3TlICVxlcV/JtIopO69Ev4E6ItG2n/h/FTA3FK+ +VeJJJcohCc/i7elwJiRiLoluIi2MID2D99G14XQcXbnLttVgkwaWHMy0Ck4AagTW +ui/qxwIDAQABo4GhMIGeMB0GA1UdDgQWBBRyFKKTfpYn1+nwiddTUhER2bVbizAf +BgNVHSMEGDAWgBQh6N622GQBcgLFHMoWDNkFGhShDDAsBgNVHREEJTAjgglsb2Nh +bGhvc3SHBH8AAAGHEAAAAAAAAAAAAAAAAAAAAAEwCQYDVR0TBAIwADAOBgNVHQ8B +Af8EBAMCBaAwEwYDVR0lBAwwCgYIKwYBBQUHAwEwDQYJKoZIhvcNAQELBQADggEB +ACkDTpEZa0i0CYn7M0e/Q5dX8SMK54ki33sFl88sPy8mL9uBLohAl85YpcPQeAgq +idem/YeaIiuC6F75llaLCXyENQggxR66+3+qkl0sHm41UW2L9N66AUOgf+AD+JRf +isWpS2TdZK6OedNIEXfEeKkU3Agpdr3qnYgJtJWcKUGWdyHOp8u6WwU4vFsGYyT0 +QSWzTUWGlfGKQbRNiiBwuZmIppaTs4FtgAZJKUf9MIM/5e9Sl9KS+0O6/f4Vv6OE +VeXJ2z5fABQoP4aOcmXLLOWOdTkU5+WCkm77PatAHMn4bLyksWi1j1iCeKGUjsm3 ++7u9qs31DNkAcPtPyj3R52s= +-----END CERTIFICATE----- +Certificate: + Data: + Version: 3 (0x2) + Serial Number: + 11:82:5d:80:30:4c:a9:6d:ed:68:88:10:c8:90:4d:08:50:3c:4c:b0 + Signature Algorithm: sha256WithRSAEncryption + Issuer: CN=Root Certification Authority + Validity + Not Before: Jul 3 19:47:44 2020 GMT + Not After : Jul 4 19:47:44 2120 GMT + Subject: CN=Root Certification Authority + Subject Public Key Info: + Public Key Algorithm: rsaEncryption + RSA Public-Key: (2048 bit) + Modulus: + 00:c5:f2:d9:a9:48:a2:06:dc:89:7d:e8:ab:2e:1f: + 70:ea:da:82:46:45:4e:42:38:6e:8d:a6:3e:28:84: + f1:25:c0:ea:25:af:61:ca:87:38:a5:7b:3f:d0:3a: + 57:82:c7:eb:f1:b5:b4:70:0e:71:69:22:5f:ae:49: + d3:51:df:19:97:bf:00:c3:de:99:3a:4d:f3:6d:4a: + bf:73:7e:b1:aa:72:40:b1:0d:fc:d4:af:11:f5:a9: + 7e:c3:36:7a:ac:25:86:a4:3e:7a:fe:3f:0f:22:f7: + d6:87:15:ba:33:c1:36:c3:79:4d:79:b3:ca:a5:2d: + 15:9a:63:ad:38:32:99:74:76:d7:72:7e:2f:69:ff: + 7b:b0:f6:79:ad:da:2d:9f:51:4e:d9:70:15:9c:83: + e9:10:8c:ec:7f:39:27:5d:b9:6e:86:c9:93:54:6b: + aa:82:12:82:b0:32:36:c5:94:6c:48:bb:3f:c6:af: + ef:1c:e1:0c:18:e6:0c:4c:bf:58:67:5b:1a:cd:15: + 62:37:40:40:5f:1d:76:e2:24:01:28:65:cc:ed:3f: + e1:f1:08:79:94:12:13:4c:4c:e2:a4:53:b8:fe:78: + 7f:07:00:cd:c1:3a:7b:0e:f4:35:ce:83:c7:f3:ce: + 71:9d:1f:7b:88:66:bc:b6:39:5e:26:28:e5:ef:5a: + 0d:05 + Exponent: 65537 (0x10001) + X509v3 extensions: + X509v3 Subject Key Identifier: + 21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C + X509v3 Authority Key Identifier: + keyid:21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C + + X509v3 Basic Constraints: critical + CA:TRUE + X509v3 Key Usage: critical + Certificate Sign, CRL Sign + Signature Algorithm: sha256WithRSAEncryption + 9d:4c:17:84:f3:83:90:97:a7:df:e5:af:53:ac:d7:75:94:c4: + a0:29:fa:d7:8f:a6:f8:fa:4b:d6:5e:d2:6e:8d:6d:46:89:1f: + 7b:30:2c:2d:d3:3b:b6:64:1d:ec:ad:60:c1:96:4b:9a:bc:f9: + d0:5d:af:a1:73:f7:03:99:8a:e2:59:47:48:1c:8f:7a:99:97: + 20:78:e2:16:16:e4:c3:c9:82:4e:25:58:23:75:c9:9c:71:67: + 8e:c4:79:e1:b9:ac:d9:c2:51:41:3d:a6:bf:07:0b:4b:14:8c: + ca:42:0f:c3:b7:71:c0:fb:3e:5e:de:2b:e5:7f:92:52:50:12: + 4f:63:a5:fa:3b:63:59:fa:37:3f:42:f4:ec:13:a0:c7:5d:0c: + 9c:cd:6b:32:96:e7:44:da:5f:8c:cf:c7:51:eb:81:3b:cc:e8: + 39:41:0c:a1:bb:8f:3a:f8:b1:ee:2b:97:f4:13:c9:a8:9c:1c: + 2f:2f:51:57:e4:0c:4e:2b:29:7f:5e:12:72:63:8c:bb:40:2c: + 97:14:bf:1e:7a:66:bc:64:af:78:80:64:19:37:ca:7a:f3:de: + 15:e6:23:1d:d0:90:7d:e6:5f:21:88:23:c5:23:ca:f2:29:00: + 1d:9a:7a:58:37:6d:a9:9e:ab:24:b1:c6:c5:3b:46:11:a7:53: + 80:ef:aa:9c +-----BEGIN CERTIFICATE----- +MIIDQTCCAimgAwIBAgIUEYJdgDBMqW3taIgQyJBNCFA8TLAwDQYJKoZIhvcNAQEL +BQAwJzElMCMGA1UEAwwcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAgFw0y +MDA3MDMxOTQ3NDRaGA8yMTIwMDcwNDE5NDc0NFowJzElMCMGA1UEAwwcUm9vdCBD +ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC +AQoCggEBAMXy2alIogbciX3oqy4fcOragkZFTkI4bo2mPiiE8SXA6iWvYcqHOKV7 +P9A6V4LH6/G1tHAOcWkiX65J01HfGZe/AMPemTpN821Kv3N+sapyQLEN/NSvEfWp +fsM2eqwlhqQ+ev4/DyL31ocVujPBNsN5TXmzyqUtFZpjrTgymXR213J+L2n/e7D2 +ea3aLZ9RTtlwFZyD6RCM7H85J125bobJk1RrqoISgrAyNsWUbEi7P8av7xzhDBjm +DEy/WGdbGs0VYjdAQF8dduIkAShlzO0/4fEIeZQSE0xM4qRTuP54fwcAzcE6ew70 +Nc6Dx/POcZ0fe4hmvLY5XiYo5e9aDQUCAwEAAaNjMGEwHQYDVR0OBBYEFCHo3rbY +ZAFyAsUcyhYM2QUaFKEMMB8GA1UdIwQYMBaAFCHo3rbYZAFyAsUcyhYM2QUaFKEM +MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBCwUA +A4IBAQCdTBeE84OQl6ff5a9TrNd1lMSgKfrXj6b4+kvWXtJujW1GiR97MCwt0zu2 +ZB3srWDBlkuavPnQXa+hc/cDmYriWUdIHI96mZcgeOIWFuTDyYJOJVgjdcmccWeO +xHnhuazZwlFBPaa/BwtLFIzKQg/Dt3HA+z5e3ivlf5JSUBJPY6X6O2NZ+jc/QvTs +E6DHXQyczWsyludE2l+Mz8dR64E7zOg5QQyhu486+LHuK5f0E8monBwvL1FX5AxO +Kyl/XhJyY4y7QCyXFL8eema8ZK94gGQZN8p6894V5iMd0JB95l8hiCPFI8ryKQAd +mnpYN22pnqskscbFO0YRp1OA76qc +-----END CERTIFICATE----- diff -Nru ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem --- ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQDnP5rW+E3DiWkf +q5UAtCDrNnLhR7oM2CB2n3js8tQcLUdseaevzuj2kcHo8ndBOzdwNhPyWzBF63TQ +9DduINVaqt7833KyB7vaHGa3ciDPNF9V8CM2w58BVEVwZeUqswOxnnPcojLLAuBg +iaX0mofiirxNgBuTwmHVEOvtbPygs6UiPAMCcuFxCIZCAzoNe24c87s9rajkwj98 +Cuu9wYkd8bztQ35HlODzF20Tlr6vdOUgJXGVxX8m0iik7r0S/gToi0baf+H8VMDc +Ur5V4kklyiEJz+Lt6XAmJGIuiW4iLYwgPYP30bXhdBxducu21WCTBpYczLQKTgBq +BNa6L+rHAgMBAAECggEBAMSWe+m4mVNb47R6x2cbush7N1pxAaedrKtrkv/Mx6lU +jN2Y5oc9HStQakrApcUctFp+fqKQBw/JxTtGAkFrRDWaAYtz4iubC4W2k1PsgBvm +aA3E4grSbsBQhd+xoAqWuNMs405zzT5sqZcoLZ8uJ8rdKouwFsGchFL/2bGz72gk +8smGqMdH4sQep3kJhJyWio47C7pC1qnG1xNmsfJ7+MkEL/+b95WsbNUTZHkAFzE8 +l5BBLILXR10EqGCAWiuz9WGffw7JASyrV1spojOmPBneBDhfLSgWjuv/0S1pUxVx +iZWDlukHPUVQWaDWQxE9Uscup3hORRENTOIJpBsYWhECgYEA9qACG2oHCa+a3xj/ +QMdWKWVZeMnKUDlpPhlyC9ue+K4NMBSzgG3K1qURX0xAvkPEApYKBh+rqvJqTMYk +N5K+CfLaU53Weyko5v5xPj3aSnGVsYazkoxfZ31MbbIqn+JPoNjYafTo2SZJsaQ6 +Y416FMxlWf7eR4rZGr1iqptSWvUCgYEA8An2Qdk+NMGYrnL6xr+AKygm2ri1Mz7k +XVr/jhkUxhBsvPumNQAVQaEuWAx6Mwgs+uzgJrsW8UCVAta/Jo+dWlCewqrpTsIh +jJZjkP9H91oEA6GkUNy9JI6j3KRQ6I5rGNr8nJrJ4c9+yLZa85BTkTriHvZl5zZX +SberAyPREUsCgYEAx9C4JFHxRc27Ispz9J4MlxmANjb37au2MxQWrLjRwhXypWQA +UyuhTesLejSjuAPbiWTa1j9OrQAfU/itW0FPK2xRq7GUFtEwTIcWZSFj/TCt4dmL +IE8O9SA1jiLuGgAYF+/Y13AQP++fgYfXrtTvdm5sJ1Ax87DxWZLbn/Kb9QkCgYEA +xjgDwlbKVrh0A8LxMcSb64eJpl6XS40o+aqWlFpD3Fdd5CWPF/9Mjliys4UCODgN +JN0NMQ6YIHsrUh/R098OmrEumSSX6zDGkZjy+Z7FaA5OeE04KopOKu0bha2vHovV +Br53kj8EbVNyp/5mVvGdALX2Wokwl2E5baedMceW8scCgYAwhrNIV1I6f76EgXP6 +3XU1B5c6VVk/Mlaid1Y7IrqPrhp1vcY2txZQ/NFEnvS1UMTvTskccgpIJJLd27D7 +CxDQGrXTfFOONZN6KzArGtX/m3PiTs6Mz3Zn8R5rJsCvda4kxEu0WV9KqZRSDGoM +pAawXm36qael22agLPA2zeH9Gg== +-----END PRIVATE KEY----- diff -Nru ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD.pm ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD.pm --- ddclient-3.9.1/t/lib/ddclient/Test/Fake/HTTPD.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ddclient/Test/Fake/HTTPD.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,381 @@ +# Copied from https://metacpan.org/pod/release/MASAKI/Test-Fake-HTTPD-0.08/lib/Test/Fake/HTTPD.pm +# and modified as follows: +# * Patched with https://github.com/masaki/Test-Fake-HTTPD/pull/4 to add IPv6 support. +# * Changed package name to ddclient::Test::Fake::HTTPD. +# +# License: This library is free software; you can redistribute it and/or modify it under the same +# terms as Perl itself. + +package ddclient::Test::Fake::HTTPD; + +use 5.008_001; +use strict; +use warnings; +use HTTP::Daemon; +use HTTP::Message::PSGI qw(res_from_psgi); +use Test::TCP qw(wait_port); +use URI; +use Time::HiRes (); +use Scalar::Util qw(blessed weaken); +use Carp qw(croak); +use Exporter qw(import); + +our $VERSION = '0.08'; +$VERSION = eval $VERSION; + +our @EXPORT = qw( + run_http_server run_https_server + extra_daemon_args +); + +our $ENABLE_SSL = eval { require HTTP::Daemon::SSL; 1 }; +sub enable_ssl { $ENABLE_SSL } + +our %EXTRA_DAEMON_ARGS = (); +sub extra_daemon_args (%) { %EXTRA_DAEMON_ARGS = @_ } + +sub run_http_server (&) { + my $app = shift; + __PACKAGE__->new->run($app); +} + +sub run_https_server (&) {} # noop +if ($ENABLE_SSL) { + no warnings 'redefine'; + *run_https_server = sub (&) { + my $app = shift; + __PACKAGE__->new(scheme => 'https')->run($app); + }; +} + +sub new { + my ($class, %args) = @_; + bless { + host => '127.0.0.1', + timeout => 5, + listen => 5, + scheme => 'http', + %args + }, $class; +} + +our $DAEMON_MAP = { + http => 'HTTP::Daemon', + https => 'HTTP::Daemon::SSL', +}; + +sub _daemon_class { + my $self = shift; + return $DAEMON_MAP->{$self->{scheme}}; +} + +sub run { + my ($self, $app) = @_; + + my %extra_daemon_args = $self->{daemon_args} && ref $self->{daemon_args} eq 'HASH' + ? %{ $self->{daemon_args} } + : %EXTRA_DAEMON_ARGS; + + $self->{server} = Test::TCP->new( + ($self->host ? (host => $self->host) : ()), + code => sub { + my $port = shift; + + my $d; + for (1..10) { + $d = $self->_daemon_class->new( + # Note: IO::Socket::IP ignores LocalAddr if LocalHost is set. + ($self->host ? (LocalAddr => $self->host) : ()), + LocalPort => $port, + Timeout => $self->{timeout}, + Proto => 'tcp', + Listen => $self->{listen}, + ($self->_is_win32 ? () : (ReuseAddr => 1)), + %extra_daemon_args, + ) and last; + Time::HiRes::sleep(0.1); + } + + croak(sprintf("failed to listen on address %s port %s%s", + $self->host || '', + $self->port || '', + $@ eq '' ? '' : ": $@")) unless $d; + + $d->accept; # wait for port check from parent process + + while (my $c = $d->accept) { + while (my $req = $c->get_request) { + my $res = $self->_to_http_res($app->($req)); + $c->send_response($res); + } + $c->close; + undef $c; + } + }, + ($self->{port} ? (port => $self->{port}) : ()), + ); + + weaken($self); + $self; +} + +sub scheme { + my $self = shift; + return $self->{scheme}; +} + +sub host { + my $self = shift; + return $self->{host}; +} + +sub port { + my $self = shift; + return $self->{server} ? $self->{server}->port : 0; +} + +sub host_port { + my $self = shift; + return $self->endpoint->host_port; +} + +sub endpoint { + my $self = shift; + my $uri = URI->new($self->scheme . ':'); + my $host = $self->host; + $host = 'localhost' if !defined($host) || $host eq '0.0.0.0' || $host eq '::'; + $uri->host($host); + $uri->port($self->port); + return $uri; +} + +sub _is_win32 { $^O eq 'MSWin32' } + +sub _is_psgi_res { + my ($self, $res) = @_; + return unless ref $res eq 'ARRAY'; + return unless @$res == 3; + return unless $res->[0] && $res->[0] =~ /^\d{3}$/; + return unless ref $res->[1] eq 'ARRAY' || ref $res->[1] eq 'HASH'; + return 1; +} + +sub _to_http_res { + my ($self, $res) = @_; + + my $http_res; + if (blessed($res) and $res->isa('HTTP::Response')) { + $http_res = $res; + } + elsif (blessed($res) and $res->isa('Plack::Response')) { + $http_res = res_from_psgi($res->finalize); + } + elsif ($self->_is_psgi_res($res)) { + $http_res = res_from_psgi($res); + } + + croak(sprintf '%s: response must be HTTP::Response or Plack::Response or PSGI', __PACKAGE__) + unless $http_res; + + return $http_res; +} + +1; + +=head1 NAME + +Test::Fake::HTTPD - a fake HTTP server + +=head1 SYNOPSIS + +DSL-style + + use Test::Fake::HTTPD; + + my $httpd = run_http_server { + my $req = shift; + # ... + + # 1. HTTP::Response ok + return $http_response; + # 2. Plack::Response ok + return $plack_response; + # 3. PSGI response ok + return [ 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] ]; + }; + + printf "Listening on address:port %s\n", $httpd->host_port; + # or + printf "Listening on address %s port %s\n", $httpd->host, $httpd->port; + + # access to fake HTTP server + use LWP::UserAgent; + my $res = LWP::UserAgent->new->get($httpd->endpoint); # "http://127.0.0.1:{port}" + + # Stop http server automatically at destruction time. + +OO-style + + use Test::Fake::HTTPD; + + my $httpd = Test::Fake::HTTPD->new( + timeout => 5, + daemon_args => { ... }, # HTTP::Daemon args + ); + + $httpd->run(sub { + my $req = shift; + # ... + [ 200, [ 'Content-Type', 'text/plain' ], [ 'Hello World' ] ]; + }); + + # Stop http server automatically at destruction time. + +=head1 DESCRIPTION + +Test::Fake::HTTPD is a fake HTTP server module for testing. + +=head1 FUNCTIONS + +=over 4 + +=item * C + +Starts HTTP server and returns the guard instance. + + my $httpd = run_http_server { + my $req = shift; + # ... + return $http_or_plack_or_psgi_res; + }; + + # can use $httpd guard object, same as OO-style + LWP::UserAgent->new->get($httpd->endpoint); + +=item * C + +Starts B server and returns the guard instance. + +If you use this method, you MUST install L. + + extra_daemon_args + SSL_key_file => "certs/server-key.pem", + SSL_cert_file => "certs/server-cert.pem"; + + my $httpd = run_https_server { + my $req = shift; + # ... + return $http_or_plack_or_psgi_res; + }; + + # can use $httpd guard object, same as OO-style + my $ua = LWP::UserAgent->new( + ssl_opts => { + SSL_verify_mode => 0, + verify_hostname => 0, + }, + ); + $ua->get($httpd->endpoint); + +=back + +=head1 METHODS + +=over 4 + +=item * C + +Returns a new instance. + + my $httpd = Test::Fake::HTTPD->new(%args); + +C<%args> are: + +=over 8 + +=item * C + +timeout value (default: 5) + +=item * C + +queue size for listen (default: 5) + +=item * C + +local address to listen on (default: 127.0.0.1) + +=item * C + +TCP port to listen on (default: auto detection) + +=back + + my $httpd = Test::Fake::HTTPD->new( + timeout => 10, + listen => 10, + port => 3333, + ); + +=item * C + +Starts this HTTP server. + + $httpd->run(sub { ... }); + +=item * C + +Returns a scheme of running, "http" or "https". + + my $scheme = $httpd->scheme; + +=item * C + +Returns the address the server is listening on. + +=item * C + +Returns the TCP port the server is listening on. + + my $port = $httpd->port; + +=item * C + +Returns the host:port from C (e.g., "127.0.0.1:1234", "[::1]:1234"). + + my $host_port = $httpd->host_port; + +=item * C + +Returns a URI object to the running server (e.g., "http://127.0.0.1:1234", +"https://[::1]:1234"). If C returns C, C<''>, C<'0.0.0.0'>, +or C<'::'>, the host portion of the URI is set to C. + + use LWP::UserAgent; + + my $res = LWP::UserAgent->new->get($httpd->endpoint); + + my $url = $httpd->endpoint; + $url->path('/foo/bar'); + my $res = LWP::UserAgent->new->get($url); + +=back + +=head1 AUTHOR + +NAKAGAWA Masaki Emasaki@cpan.orgE + +=head1 THANKS TO + +xaicron + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L, L, L + +=cut diff -Nru ddclient-3.9.1/t/lib/ddclient/t.pm ddclient-3.10.0/t/lib/ddclient/t.pm --- ddclient-3.9.1/t/lib/ddclient/t.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ddclient/t.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,562 @@ +package ddclient::t; +require v5.10.1; +use strict; +use warnings; + + +###################################################################### +## Outputs from ip addr and ifconfig commands to find IP address from IF name +## Samples from Ubuntu 20.04, RHEL8, Buildroot, Busybox, MacOS 10.15, FreeBSD +## NOTE: Any tabs/whitespace at start or end of lines are intentional to match real life data. +###################################################################### +our @interface_samples = ( + # This seems to be consistent accross platforms. The last line is from Ubuntu of a static + # assigned IPv6. + { + name => 'ip -6 -o addr show dev scope global', + text => <<'EOF', +2: ens160 inet6 fdb6:1d86:d9bd:1::8214/128 scope global dynamic noprefixroute \ valid_lft 63197sec preferred_lft 63197sec +2: ens160 inet6 2001:db8:4341:0781::8214/128 scope global dynamic noprefixroute \ valid_lft 63197sec preferred_lft 63197sec +2: ens160 inet6 2001:db8:4341:0781:89b9:4b1c:186c:a0c7/64 scope global temporary dynamic \ valid_lft 85954sec preferred_lft 21767sec +2: ens160 inet6 fdb6:1d86:d9bd:1:89b9:4b1c:186c:a0c7/64 scope global temporary dynamic \ valid_lft 85954sec preferred_lft 21767sec +2: ens160 inet6 fdb6:1d86:d9bd:1:34a6:c329:c52e:8ba6/64 scope global temporary deprecated dynamic \ valid_lft 85954sec preferred_lft 0sec +2: ens160 inet6 fdb6:1d86:d9bd:1:b417:fe35:166b:4816/64 scope global dynamic mngtmpaddr noprefixroute \ valid_lft 85954sec preferred_lft 85954sec +2: ens160 inet6 2001:db8:4341:0781:34a6:c329:c52e:8ba6/64 scope global temporary deprecated dynamic \ valid_lft 85954sec preferred_lft 0sec +2: ens160 inet6 2001:db8:4341:0781:f911:a224:7e69:d22/64 scope global dynamic mngtmpaddr noprefixroute \ valid_lft 85954sec preferred_lft 85954sec +2: ens160 inet6 2001:db8:4341:0781::100/128 scope global noprefixroute \ valid_lft forever preferred_lft forever +EOF + want_extract_ipv6_global => '2001:db8:4341:781::8214', + want_ipv6gua_from_if => "2001:db8:4341:781::100", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:1::8214", + }, + # (Yes, there is a tab at start of each line.) The last lines is with a manually + # configured static GUA. + { + name => 'MacOS: ifconfig | grep -w inet6', + MacOS => 1, + text => <<'EOF', + inet6 fe80::1419:abd0:5943:8bbb%en0 prefixlen 64 secured scopeid 0xa + inet6 fdb6:1d86:d9bd:1:142c:8e9e:de48:843e prefixlen 64 autoconf secured + inet6 fdb6:1d86:d9bd:1:7447:cf67:edbd:cea4 prefixlen 64 autoconf temporary + inet6 fdb6:1d86:d9bd:1::c5b3 prefixlen 64 dynamic + inet6 2001:db8:4341:0781:141d:66b9:2ba1:b67d prefixlen 64 autoconf secured + inet6 2001:db8:4341:0781:64e1:b68f:e8af:5d6e prefixlen 64 autoconf temporary + inet6 2001:db8:4341:0781::101 prefixlen 64 +EOF + want_extract_ipv6_global => '2001:db8:4341:781:141d:66b9:2ba1:b67d', + want_ipv6gua_from_if => "2001:db8:4341:781::101", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:1::c5b3", + }, + { + name => 'RHEL: ifconfig | grep -w inet6', + text => <<'EOF', + inet6 2001:db8:4341:0781::dc14 prefixlen 128 scopeid 0x0 + inet6 fe80::cd48:4a58:3b0f:4d30 prefixlen 64 scopeid 0x20 + inet6 2001:db8:4341:0781:e720:3aec:a936:36d4 prefixlen 64 scopeid 0x0 + inet6 fdb6:1d86:d9bd:1:9c16:8cbf:ae33:f1cc prefixlen 64 scopeid 0x0 + inet6 fdb6:1d86:d9bd:1::dc14 prefixlen 128 scopeid 0x0 +EOF + want_extract_ipv6_global => '2001:db8:4341:781::dc14', + want_ipv6gua_from_if => "2001:db8:4341:781::dc14", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:1::dc14", + }, + { + name => 'Ubuntu: ifconfig | grep -w inet6', + text => <<'EOF', + inet6 fdb6:1d86:d9bd:1:34a6:c329:c52e:8ba6 prefixlen 64 scopeid 0x0 + inet6 fdb6:1d86:d9bd:1:89b9:4b1c:186c:a0c7 prefixlen 64 scopeid 0x0 + inet6 fdb6:1d86:d9bd:1::8214 prefixlen 128 scopeid 0x0 + inet6 fdb6:1d86:d9bd:1:b417:fe35:166b:4816 prefixlen 64 scopeid 0x0 + inet6 fe80::5b31:fc63:d353:da68 prefixlen 64 scopeid 0x20 + inet6 2001:db8:4341:0781::8214 prefixlen 128 scopeid 0x0 + inet6 2001:db8:4341:0781:34a6:c329:c52e:8ba6 prefixlen 64 scopeid 0x0 + inet6 2001:db8:4341:0781:89b9:4b1c:186c:a0c7 prefixlen 64 scopeid 0x0 + inet6 2001:db8:4341:0781:f911:a224:7e69:d22 prefixlen 64 scopeid 0x0 +EOF + want_extract_ipv6_global => '2001:db8:4341:781::8214', + want_ipv6gua_from_if => "2001:db8:4341:781::8214", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:1::8214", + }, + { + name => 'Busybox: ifconfig | grep -w inet6', + text => <<'EOF', + inet6 addr: fe80::4362:31ff:fe08:61b4/64 Scope:Link + inet6 addr: 2001:db8:4341:781:ed44:eb63:b070:212f/128 Scope:Global +EOF + want_extract_ipv6_global => '2001:db8:4341:781:ed44:eb63:b070:212f', + want_ipv6gua_from_if => "2001:db8:4341:781:ed44:eb63:b070:212f", + }, + { name => "ip -4 -o addr show dev ens33 scope global (most linux IPv4)", + text => < "198.51.100.33", + }, + { name => "ip -6 -o addr show dev ens33 scope global (most linux)", + text => < "2001:db8:450a:e723:adee:be82:7fba:ffb2", + want_ipv6gua_from_if => "2001:db8:450a:e723::21", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3::21", + }, + { name => "ip -6 -o addr show dev ens33 scope global (most linux static IPv6)", + text => < "2001:db8:450a:e723::101", + want_ipv6gua_from_if => "2001:db8:450a:e723::101", + }, + { name => "ifconfig ens33 (most linux autoconf IPv6 and DHCPv6)", + text => < mtu 1500 + inet 198.51.100.33 netmask 255.255.255.0 broadcast 198.51.100.255 + inet6 fdb6:1d86:d9bd:3::21 prefixlen 128 scopeid 0x0 + inet6 fe80::32c0:b270:245b:d3b4 prefixlen 64 scopeid 0x20 + inet6 fdb6:1d86:d9bd:3:a1fd:1ed9:6211:4268 prefixlen 64 scopeid 0x0 + inet6 2001:db8:450a:e723:adee:be82:7fba:ffb2 prefixlen 64 scopeid 0x0 + inet6 2001:db8:450a:e723::21 prefixlen 128 scopeid 0x0 + inet6 fdb6:1d86:d9bd:3:adee:be82:7fba:ffb2 prefixlen 64 scopeid 0x0 + inet6 2001:db8:450a:e723:dbc5:1c4e:9e9b:97a2 prefixlen 64 scopeid 0x0 + ether 00:00:00:da:24:b1 txqueuelen 1000 (Ethernet) + RX packets 3782541 bytes 556082941 (556.0 MB) + RX errors 0 dropped 513 overruns 0 frame 0 + TX packets 33294 bytes 6838768 (6.8 MB) + TX errors 0 dropped 0 overruns 0 carrier 0 collisions 0 +EOF + want_extract_ipv6_global => "2001:db8:450a:e723:adee:be82:7fba:ffb2", + want_ipv6gua_from_if => "2001:db8:450a:e723::21", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3::21", + want_ipv4_from_if => "198.51.100.33", + }, + { name => "ifconfig ens33 (most linux DHCPv6)", + text => < mtu 1500 + inet 198.51.100.33 netmask 255.255.255.0 broadcast 198.51.100.255 + inet6 fdb6:1d86:d9bd:3::21 prefixlen 128 scopeid 0x0 + inet6 fe80::32c0:b270:245b:d3b4 prefixlen 64 scopeid 0x20 + inet6 2001:db8:450a:e723::21 prefixlen 128 scopeid 0x0 + ether 00:00:00:da:24:b1 txqueuelen 1000 (Ethernet) + RX packets 3781554 bytes 555602847 (555.6 MB) + RX errors 0 dropped 513 overruns 0 frame 0 + TX packets 32493 bytes 6706131 (6.7 MB) + TX errors 0 dropped 0 overruns 0 carrier 0 collisions 0 +EOF + want_extract_ipv6_global => "2001:db8:450a:e723::21", + want_ipv6gua_from_if => "2001:db8:450a:e723::21", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3::21", + want_ipv4_from_if => "198.51.100.33", + }, + { name => "ifconfig ens33 (most linux static IPv6)", + text => < mtu 1500 + inet 198.51.100.33 netmask 255.255.255.0 broadcast 198.51.100.255 + inet6 fe80::32c0:b270:245b:d3b4 prefixlen 64 scopeid 0x20 + inet6 2001:db8:450a:e723::101 prefixlen 64 scopeid 0x0 + ether 00:00:00:da:24:b1 txqueuelen 1000 (Ethernet) + RX packets 3780219 bytes 554967876 (554.9 MB) + RX errors 0 dropped 513 overruns 0 frame 0 + TX packets 31556 bytes 6552122 (6.5 MB) + TX errors 0 dropped 0 overruns 0 carrier 0 collisions 0 +EOF + want_extract_ipv6_global => "2001:db8:450a:e723::101", + want_ipv6gua_from_if => "2001:db8:450a:e723::101", + want_ipv4_from_if => "198.51.100.33", + }, + { name => "ifconfig en0 (MacOS IPv4)", + text => < mtu 9000 + options=50b + ether 00:00:00:90:32:8f + inet6 fe80::85b:d150:cdd9:3198%en0 prefixlen 64 secured scopeid 0x4 + inet6 2001:db8:450a:e723:1c99:99e2:21d0:79e6 prefixlen 64 autoconf secured + inet6 2001:db8:450a:e723:808d:d894:e4db:157e prefixlen 64 deprecated autoconf temporary + inet6 fdb6:1d86:d9bd:3:837:e1c7:4895:269e prefixlen 64 autoconf secured + inet6 fdb6:1d86:d9bd:3:a0b3:aa4d:9e76:e1ab prefixlen 64 deprecated autoconf temporary + inet 198.51.100.5 netmask 0xffffff00 broadcast 198.51.100.255 + inet6 2001:db8:450a:e723:2474:39fd:f5c0:6845 prefixlen 64 autoconf temporary + inet6 fdb6:1d86:d9bd:3:2474:39fd:f5c0:6845 prefixlen 64 autoconf temporary + inet6 fdb6:1d86:d9bd:3::8076 prefixlen 64 dynamic + nd6 options=201 + media: 1000baseT + status: active +EOF + want_extract_ipv6_global => "2001:db8:450a:e723:1c99:99e2:21d0:79e6", + want_ipv6gua_from_if => "2001:db8:450a:e723:1c99:99e2:21d0:79e6", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3::8076", + want_ipv4_from_if => "198.51.100.5", + }, + { name => "ifconfig em0 (FreeBSD IPv4)", + text => < metric 0 mtu 1500 + options=81009b + ether 00:00:00:9f:c5:32 + inet6 fe80::20c:29ff:fe9f:c532%em0 prefixlen 64 scopeid 0x1 + inet6 2001:db8:450a:e723:20c:29ff:fe9f:c532 prefixlen 64 autoconf + inet6 fdb6:1d86:d9bd:3:20c:29ff:fe9f:c532 prefixlen 64 autoconf + inet 198.51.100.207 netmask 0xffffff00 broadcast 198.51.100.255 + media: Ethernet autoselect (1000baseT ) + status: active + nd6 options=23 +EOF + want_extract_ipv6_global => "2001:db8:450a:e723:20c:29ff:fe9f:c532", + want_ipv6gua_from_if => "2001:db8:450a:e723:20c:29ff:fe9f:c532", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3:20c:29ff:fe9f:c532", + want_ipv4_from_if => "198.51.100.207", + }, + { name => "ifconfig -L en0 (MacOS autoconf IPv6)", + MacOS => 1, + text => < mtu 9000 + options=50b + ether 00:00:00:90:32:8f + inet6 fe80::85b:d150:cdd9:3198%en0 prefixlen 64 secured scopeid 0x4 + inet6 2001:db8:450a:e723:1c99:99e2:21d0:79e6 prefixlen 64 autoconf secured pltime 86205 vltime 86205 + inet6 2001:db8:450a:e723:808d:d894:e4db:157e prefixlen 64 deprecated autoconf temporary pltime 0 vltime 86205 + inet6 fdb6:1d86:d9bd:3:837:e1c7:4895:269e prefixlen 64 autoconf secured pltime 86205 vltime 86205 + inet6 fdb6:1d86:d9bd:3:a0b3:aa4d:9e76:e1ab prefixlen 64 deprecated autoconf temporary pltime 0 vltime 86205 + inet 198.51.100.5 netmask 0xffffff00 broadcast 198.51.100.255 + inet6 2001:db8:450a:e723:2474:39fd:f5c0:6845 prefixlen 64 autoconf temporary pltime 76882 vltime 86205 + inet6 fdb6:1d86:d9bd:3:2474:39fd:f5c0:6845 prefixlen 64 autoconf temporary pltime 76882 vltime 86205 + inet6 fdb6:1d86:d9bd:3::8076 prefixlen 64 dynamic pltime 78010 vltime 78010 + nd6 options=201 + media: 1000baseT + status: active +EOF + want_extract_ipv6_global => "2001:db8:450a:e723:1c99:99e2:21d0:79e6", + want_ipv6gua_from_if => "2001:db8:450a:e723:1c99:99e2:21d0:79e6", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3::8076", + want_ipv4_from_if => "198.51.100.5", + }, + { name => "ifconfig -L en0 (MacOS static IPv6)", + MacOS => 1, + text => < mtu 1500 + options=400 + ether 00:00:00:42:96:eb + inet 198.51.100.199 netmask 0xffffff00 broadcast 198.51.100.255 + inet6 fe80::1445:78b9:1d5c:11eb%en1 prefixlen 64 secured scopeid 0x5 + inet6 2001:db8:450a:e723::100 prefixlen 64 + nd6 options=201 + media: autoselect + status: active +EOF + want_extract_ipv6_global => "2001:db8:450a:e723::100", + want_ipv6gua_from_if => "2001:db8:450a:e723::100", + want_ipv4_from_if => "198.51.100.199", + }, + { name => "ifconfig -L em0 (FreeBSD autoconf IPv6)", + MacOS => 1, + text => < metric 0 mtu 1500 + options=81009b + ether 00:00:00:9f:c5:32 + inet6 fe80::20c:29ff:fe9f:c532%em0 prefixlen 64 scopeid 0x1 + inet6 2001:db8:450a:e723:20c:29ff:fe9f:c532 prefixlen 64 autoconf pltime 86114 vltime 86114 + inet6 fdb6:1d86:d9bd:3:20c:29ff:fe9f:c532 prefixlen 64 autoconf pltime 86114 vltime 86114 + inet 198.51.100.207 netmask 0xffffff00 broadcast 198.51.100.255 + media: Ethernet autoselect (1000baseT ) + status: active + nd6 options=23 +EOF + want_extract_ipv6_global => "2001:db8:450a:e723:20c:29ff:fe9f:c532", + want_ipv6gua_from_if => "2001:db8:450a:e723:20c:29ff:fe9f:c532", + want_ipv6ula_from_if => "fdb6:1d86:d9bd:3:20c:29ff:fe9f:c532", + want_ipv4_from_if => "198.51.100.207", + }, + { name => "ip -4 -o addr show dev eth0 scope global (Buildroot IPv4)", + text => < "198.51.157.237", + }, + { name => "ip -6 -o addr show dev eth0 scope global (Buildroot IPv6)", + text => < "2001:db8:450b:13f:ed44:eb63:b070:212f", + want_ipv6gua_from_if => "2001:db8:450b:13f:ed44:eb63:b070:212f", + }, + { name => "ifconfig eth0 (Busybox)", + text => < "2001:db8:450b:13f:ed44:eb63:b070:212f", + want_ipv6gua_from_if => "2001:db8:450b:13f:ed44:eb63:b070:212f", + want_ipv4_from_if => "198.51.157.237", + }, +); + +###################################################################### +## Outputs from ip route and netstat commands to find default route (and therefore interface) +## Samples from Ubuntu 20.04, RHEL8, Buildroot, Busybox, MacOS 10.15, FreeBSD +## NOTE: Any tabs/whitespace at start or end of lines are intentional to match real life data. +###################################################################### +our @routing_samples = ( + { name => "ip -4 -o route list match default (most linux)", + text => < "ens33", + }, + { name => "ip -4 -o route list match default (most linux)", + text => < "ens33", + }, + { name => "ip -4 -o route list match default (buildroot)", + text => < "eth0", + }, + { name => "ip -6 -o route list match default (buildroot)", + text => < "eth0", + }, + { name => "netstat -rn -4 (most linux)", + text => < "ens33", + }, + { name => "netstat -rn -4 (FreeBSD)", + text => < "em0", + }, + { name => "netstat -rn -6 (FreeBSD)", + text => < "em0", + }, + { name => "netstat -rn -6 (most linux)", + text => < "ens33", + }, + { name => "netstat -rn -f inet (MacOS)", + text => < "en0", + }, + { name => "netstat -rn -f inet6 (MacOS)", + text => < "en0", + }, +); diff -Nru ddclient-3.9.1/t/lib/Devel/Autoflush.pm ddclient-3.10.0/t/lib/Devel/Autoflush.pm --- ddclient-3.9.1/t/lib/Devel/Autoflush.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Devel/Autoflush.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,106 @@ +package Devel::Autoflush; +# ABSTRACT: Set autoflush from the command line +our $VERSION = '0.06'; # VERSION + +my $kwalitee_nocritic = << 'END'; +# can't use strict as older stricts load Carp and we can't allow side effects +use strict; +END + +my $old = select STDOUT; +$|++; +select STDERR; +$|++; +select $old; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Devel::Autoflush - Set autoflush from the command line + +=head1 VERSION + +version 0.06 + +=head1 SYNOPSIS + + perl -MDevel::Autoflush Makefile.PL + +=head1 DESCRIPTION + +This module is a hack to set autoflush for STDOUT and STDERR from the command +line or from C for code that needs it but doesn't have it. + +This often happens when prompting: + + # guess.pl + print "Guess a number: "; + my $n = ; + +As long as the output is going to a terminal, the prompt is flushed when STDIN +is read. However, if the output is being piped, the print statement will +not automatically be flushed, no prompt will be seen and the program will +silently appear to hang while waiting for input. This might happen with 'tee': + + $ perl guess.pl | tee capture.out + +Use Devel::Autoflush to work around this: + + $ perl -MDevel::Autoflush guess.pl | tee capture.out + +Or set it in C: + + $ export PERL5OPT=-MDevel::Autoflush + $ perl guess.pl | tee capture.out + += SEE ALSO + +=over 4 + +=item * + +L -- same idea but STDOUT only and + +only available as part of the full CPANPLUS distribution + +=back + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L + + git clone https://github.com/dagolden/Devel-Autoflush.git + +=head1 AUTHOR + +David Golden + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2014 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut diff -Nru ddclient-3.9.1/t/lib/ok.pm ddclient-3.10.0/t/lib/ok.pm --- ddclient-3.9.1/t/lib/ok.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/ok.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,49 @@ +package ok; +our $VERSION = '1.302175'; + +use strict; +use Test::More (); + +sub import { + shift; + + if (@_) { + goto &Test::More::pass if $_[0] eq 'ok'; + goto &Test::More::use_ok; + } + + # No argument list - croak as if we are prototyped like use_ok() + my (undef, $file, $line) = caller(); + ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; +} + + +__END__ + +=encoding UTF-8 + +=head1 NAME + +ok - Alternative to Test::More::use_ok + +=head1 SYNOPSIS + + use ok 'Some::Module'; + +=head1 DESCRIPTION + +With this module, simply change all C in test scripts to C, +and they will be executed at C time. + +Please see L for the full description. + +=head1 CC0 1.0 Universal + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L. + +This work is published from Taiwan. + +L + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/Builder/Formatter.pm ddclient-3.10.0/t/lib/Test/Builder/Formatter.pm --- ddclient-3.9.1/t/lib/Test/Builder/Formatter.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/Formatter.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,107 @@ +package Test::Builder::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } + +use Test2::Util::HashBase qw/no_header no_diag/; + +BEGIN { + *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); + *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); + + my $todo = OUT_ERR() + 1; + *OUT_TODO = sub() { $todo }; +} + +sub init { + my $self = shift; + $self->SUPER::init(@_); + $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; +} + +sub plan_tap { + my ($self, $f) = @_; + + return if $self->{+NO_HEADER}; + return $self->SUPER::plan_tap($f); +} + +sub debug_tap { + my ($self, $f, $num) = @_; + return if $self->{+NO_DIAG}; + my @out = $self->SUPER::debug_tap($f, $num); + $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} + && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + return @out; +} + +sub info_tap { + my ($self, $f) = @_; + return if $self->{+NO_DIAG}; + my @out = $self->SUPER::info_tap($f); + $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} + && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + return @out; +} + +sub redirect { + my ($self, $out) = @_; + $_->[0] = OUT_TODO for @$out; +} + +sub no_subtest_space { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test::Builder; # Loads Test::Builder::Formatter for you + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/Builder/IO/Scalar.pm ddclient-3.10.0/t/lib/Test/Builder/IO/Scalar.pm --- ddclient-3.9.1/t/lib/Test/Builder/IO/Scalar.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/IO/Scalar.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,659 @@ +package Test::Builder::IO::Scalar; + + +=head1 NAME + +Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder + +=head1 DESCRIPTION + +This is a copy of L which ships with L to +support scalar references as filehandles on Perl 5.6. Newer +versions of Perl simply use C's built in support. + +L can not have dependencies on other modules without +careful consideration, so its simply been copied into the distribution. + +=head1 COPYRIGHT and LICENSE + +This file came from the "IO-stringy" Perl5 toolkit. + +Copyright (c) 1996 by Eryq. All rights reserved. +Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=cut + +# This is copied code, I don't care. +##no critic + +use Carp; +use strict; +use vars qw($VERSION @ISA); +use IO::Handle; + +use 5.005; + +### The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.114"; + +### Inheritance: +@ISA = qw(IO::Handle); + +#============================== + +=head2 Construction + +=over 4 + +=cut + +#------------------------------ + +=item new [ARGS...] + +I +Return a new, unattached scalar handle. +If any arguments are given, they're sent to open(). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless \do { local *FH }, $class; + tie *$self, $class, $self; + $self->open(@_); ### open on anonymous by default + $self; +} +sub DESTROY { + shift->close; +} + +#------------------------------ + +=item open [SCALARREF] + +I +Open the scalar handle on a new scalar, pointed to by SCALARREF. +If no SCALARREF is given, a "private" scalar is created to hold +the file data. + +Returns the self object on success, undefined on error. + +=cut + +sub open { + my ($self, $sref) = @_; + + ### Sanity: + defined($sref) or do {my $s = ''; $sref = \$s}; + (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; + + ### Setup: + *$self->{Pos} = 0; ### seek position + *$self->{SR} = $sref; ### scalar reference + $self; +} + +#------------------------------ + +=item opened + +I +Is the scalar handle opened on something? + +=cut + +sub opened { + *{shift()}->{SR}; +} + +#------------------------------ + +=item close + +I +Disassociate the scalar handle from its underlying scalar. +Done automatically on destroy. + +=cut + +sub close { + my $self = shift; + %{*$self} = (); + 1; +} + +=back + +=cut + + + +#============================== + +=head2 Input and output + +=over 4 + +=cut + + +#------------------------------ + +=item flush + +I +No-op, provided for OO compatibility. + +=cut + +sub flush { "0 but true" } + +#------------------------------ + +=item getc + +I +Return the next character, or undef if none remain. + +=cut + +sub getc { + my $self = shift; + + ### Return undef right away if at EOF; else, move pos forward: + return undef if $self->eof; + substr(${*$self->{SR}}, *$self->{Pos}++, 1); +} + +#------------------------------ + +=item getline + +I +Return the next line, or undef on end of string. +Can safely be called in an array context. +Currently, lines are delimited by "\n". + +=cut + +sub getline { + my $self = shift; + + ### Return undef right away if at EOF: + return undef if $self->eof; + + ### Get next line: + my $sr = *$self->{SR}; + my $i = *$self->{Pos}; ### Start matching at this point. + + ### Minimal impact implementation! + ### We do the fast fast thing (no regexps) if using the + ### classic input record separator. + + ### Case 1: $/ is undef: slurp all... + if (!defined($/)) { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + + ### Case 2: $/ is "\n": zoom zoom zoom... + elsif ($/ eq "\012") { + + ### Seek ahead for "\n"... yes, this really is faster than regexps. + my $len = length($$sr); + for (; $i < $len; ++$i) { + last if ord (substr ($$sr, $i, 1)) == 10; + } + + ### Extract the line: + my $line; + if ($i < $len) { ### We found a "\n": + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); + *$self->{Pos} = $i+1; ### Remember where we finished up. + } + else { ### No "\n"; slurp the remainder: + $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); + *$self->{Pos} = $len; + } + return $line; + } + + ### Case 3: $/ is ref to int. Do fixed-size records. + ### (Thanks to Dominique Quatravaux.) + elsif (ref($/)) { + my $len = length($$sr); + my $i = ${$/} + 0; + my $line = substr ($$sr, *$self->{Pos}, $i); + *$self->{Pos} += $i; + *$self->{Pos} = $len if (*$self->{Pos} > $len); + return $line; + } + + ### Case 4: $/ is either "" (paragraphs) or something weird... + ### This is Graham's general-purpose stuff, which might be + ### a tad slower than Case 2 for typical data, because + ### of the regexps. + else { + pos($$sr) = $i; + + ### If in paragraph mode, skip leading lines (and update i!): + length($/) or + (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); + + ### If we see the separator in the buffer ahead... + if (length($/) + ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! + : $$sr =~ m,\n\n,g ### (a paragraph) + ) { + *$self->{Pos} = pos $$sr; + return substr($$sr, $i, *$self->{Pos}-$i); + } + ### Else if no separator remains, just slurp the rest: + else { + *$self->{Pos} = length $$sr; + return substr($$sr, $i); + } + } +} + +#------------------------------ + +=item getlines + +I +Get all remaining lines. +It will croak() if accidentally called in a scalar context. + +=cut + +sub getlines { + my $self = shift; + wantarray or croak("can't call getlines in scalar context!"); + my ($line, @lines); + push @lines, $line while (defined($line = $self->getline)); + @lines; +} + +#------------------------------ + +=item print ARGS... + +I +Print ARGS to the underlying scalar. + +B this continues to always cause a seek to the end +of the string, but if you perform seek()s and tell()s, it is +still safer to explicitly seek-to-end before subsequent print()s. + +=cut + +sub print { + my $self = shift; + *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); + 1; +} +sub _unsafe_print { + my $self = shift; + my $append = join('', @_) . $\; + ${*$self->{SR}} .= $append; + *$self->{Pos} += length($append); + 1; +} +sub _old_print { + my $self = shift; + ${*$self->{SR}} .= join('', @_) . $\; + *$self->{Pos} = length(${*$self->{SR}}); + 1; +} + + +#------------------------------ + +=item read BUF, NBYTES, [OFFSET] + +I +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub read { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); + $n = length($read); + *$self->{Pos} += $n; + ($off ? substr($_[1], $off) : $_[1]) = $read; + return $n; +} + +#------------------------------ + +=item write BUF, NBYTES, [OFFSET] + +I +Write some bytes to the scalar. + +=cut + +sub write { + my $self = $_[0]; + my $n = $_[2]; + my $off = $_[3] || 0; + + my $data = substr($_[1], $off, $n); + $n = length($data); + $self->print($data); + return $n; +} + +#------------------------------ + +=item sysread BUF, LEN, [OFFSET] + +I +Read some bytes from the scalar. +Returns the number of bytes actually read, 0 on end-of-file, undef on error. + +=cut + +sub sysread { + my $self = shift; + $self->read(@_); +} + +#------------------------------ + +=item syswrite BUF, NBYTES, [OFFSET] + +I +Write some bytes to the scalar. + +=cut + +sub syswrite { + my $self = shift; + $self->write(@_); +} + +=back + +=cut + + +#============================== + +=head2 Seeking/telling and other attributes + +=over 4 + +=cut + + +#------------------------------ + +=item autoflush + +I +No-op, provided for OO compatibility. + +=cut + +sub autoflush {} + +#------------------------------ + +=item binmode + +I +No-op, provided for OO compatibility. + +=cut + +sub binmode {} + +#------------------------------ + +=item clearerr + +I Clear the error and EOF flags. A no-op. + +=cut + +sub clearerr { 1 } + +#------------------------------ + +=item eof + +I Are we at end of file? + +=cut + +sub eof { + my $self = shift; + (*$self->{Pos} >= length(${*$self->{SR}})); +} + +#------------------------------ + +=item seek OFFSET, WHENCE + +I Seek to a given position in the stream. + +=cut + +sub seek { + my ($self, $pos, $whence) = @_; + my $eofpos = length(${*$self->{SR}}); + + ### Seek: + if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET + elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR + elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END + else { croak "bad seek whence ($whence)" } + + ### Fixup: + if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } + if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } + return 1; +} + +#------------------------------ + +=item sysseek OFFSET, WHENCE + +I Identical to C, I + +=cut + +sub sysseek { + my $self = shift; + $self->seek (@_); +} + +#------------------------------ + +=item tell + +I +Return the current position in the stream, as a numeric offset. + +=cut + +sub tell { *{shift()}->{Pos} } + +#------------------------------ + +=item use_RS [YESNO] + +I +B +Obey the current setting of $/, like IO::Handle does? +Default is false in 1.x, but cold-welded true in 2.x and later. + +=cut + +sub use_RS { + my ($self, $yesno) = @_; + carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; + } + +#------------------------------ + +=item setpos POS + +I +Set the current position, using the opaque value returned by C. + +=cut + +sub setpos { shift->seek($_[0],0) } + +#------------------------------ + +=item getpos + +I +Return the current position in the string, as an opaque object. + +=cut + +*getpos = \&tell; + + +#------------------------------ + +=item sref + +I +Return a reference to the underlying scalar. + +=cut + +sub sref { *{shift()}->{SR} } + + +#------------------------------ +# Tied handle methods... +#------------------------------ + +# Conventional tiehandle interface: +sub TIEHANDLE { + ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) + ? $_[1] + : shift->new(@_)); +} +sub GETC { shift->getc(@_) } +sub PRINT { shift->print(@_) } +sub PRINTF { shift->print(sprintf(shift, @_)) } +sub READ { shift->read(@_) } +sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } +sub WRITE { shift->write(@_); } +sub CLOSE { shift->close(@_); } +sub SEEK { shift->seek(@_); } +sub TELL { shift->tell(@_); } +sub EOF { shift->eof(@_); } +sub FILENO { -1 } + +#------------------------------------------------------------ + +1; + +__END__ + + + +=back + +=cut + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C, C, and C. +Attempting to use these functions with an IO::Scalar will not work +prior to 5.005_57. IO::Scalar will not have the relevant methods +invoked; and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C), +and you see something like this... + + attempt to seek on unopened filehandle + +...then you are probably trying to use one of these functions +on an IO::Scalar with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + +=head1 VERSION + +$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHORS + +=head2 Primary Maintainer + +David F. Skoll (F). + +=head2 Principal author + +Eryq (F). +President, ZeeGee Software Inc (F). + + +=head2 Other contributors + +The full set of contributors always includes the folks mentioned +in L. But just the same, special +thanks to the following individuals for their invaluable contributions +(if I've forgotten or misspelled your name, please email me!): + +I +for contributing C. + +I +for suggesting C. + +I +for finding and fixing the bug in C. + +I +for his offset-using read() and write() implementations. + +I +for his patches to massively improve the performance of C +and add C and C. + +I +for stringification and inheritance improvements, +and sundry good ideas. + +I +for the IO::Handle inheritance and automatic tie-ing. + + +=head1 SEE ALSO + +L, which is quite similar but which was designed +more-recently and with an IO::Handle-like interface in mind, +so you could mix OO- and native-filehandle usage without using tied(). + +I as of version 2.x, these classes all work like +their IO::Handle counterparts, so we have comparable +functionality to IO::String. + +=cut + diff -Nru ddclient-3.9.1/t/lib/Test/Builder/Module.pm ddclient-3.10.0/t/lib/Test/Builder/Module.pm --- ddclient-3.9.1/t/lib/Test/Builder/Module.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/Module.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,182 @@ +package Test::Builder::Module; + +use strict; + +use Test::Builder; + +require Exporter; +our @ISA = qw(Exporter); + +our $VERSION = '1.302175'; + + +=head1 NAME + +Test::Builder::Module - Base class for test modules + +=head1 SYNOPSIS + + # Emulates Test::Simple + package Your::Module; + + my $CLASS = __PACKAGE__; + + use parent 'Test::Builder::Module'; + @EXPORT = qw(ok); + + sub ok ($;$) { + my $tb = $CLASS->builder; + return $tb->ok(@_); + } + + 1; + + +=head1 DESCRIPTION + +This is a superclass for L-based modules. It provides a +handful of common functionality and a method of getting at the underlying +L object. + + +=head2 Importing + +Test::Builder::Module is a subclass of L which means your +module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... +all act normally. + +A few methods are provided to do the C<< use Your::Module tests => 23 >> part +for you. + +=head3 import + +Test::Builder::Module provides an C method which acts in the +same basic way as L's, setting the plan and controlling +exporting of functions and variables. This allows your module to set +the plan independent of L. + +All arguments passed to C are passed onto +C<< Your::Module->builder->plan() >> with the exception of +C<< import =>[qw(things to import)] >>. + + use Your::Module import => [qw(this that)], tests => 23; + +says to import the functions C and C as well as set the plan +to be 23 tests. + +C also sets the C attribute of your builder to be +the caller of the C function. + +Additional behaviors can be added to your C method by overriding +C. + +=cut + +sub import { + my($class) = shift; + + Test2::API::test2_load() unless Test2::API::test2_in_preload(); + + # Don't run all this when loading ourself. + return 1 if $class eq 'Test::Builder::Module'; + + my $test = $class->builder; + + my $caller = caller; + + $test->exported_to($caller); + + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); + + $test->plan(@_); + + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + $class->Exporter::import(@imports); +} + +sub _strip_imports { + my $class = shift; + my $list = shift; + + my @imports = (); + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'import' ) { + push @imports, @{ $list->[ $idx + 1 ] }; + $idx++; + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + return @imports; +} + +=head3 import_extra + + Your::Module->import_extra(\@import_args); + +C is called by C. It provides an opportunity for you +to add behaviors to your module based on its import list. + +Any extra arguments which shouldn't be passed on to C should be +stripped off by this method. + +See L for an example of its use. + +B This mechanism is I as it +feels like a bit of an ugly hack in its current form. + +=cut + +sub import_extra { } + +=head2 Builder + +Test::Builder::Module provides some methods of getting at the underlying +Test::Builder object. + +=head3 builder + + my $builder = Your::Class->builder; + +This method returns the L object associated with Your::Class. +It is not a constructor so you can call it as often as you like. + +This is the preferred way to get the L object. You should +I get it via C<< Test::Builder->new >> as was previously +recommended. + +The object returned by C may change at runtime so you should +call C inside each function rather than store it in a global. + + sub ok { + my $builder = Your::Class->builder; + + return $builder->ok(@_); + } + + +=cut + +sub builder { + return Test::Builder->new; +} + +=head1 SEE ALSO + +L<< Test2::Manual::Tooling::TestBuilder >> describes the improved +options for writing testing modules provided by L<< Test2 >>. + +=cut + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Builder/Tester/Color.pm ddclient-3.10.0/t/lib/Test/Builder/Tester/Color.pm --- ddclient-3.9.1/t/lib/Test/Builder/Tester/Color.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/Tester/Color.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,51 @@ +package Test::Builder::Tester::Color; + +use strict; +our $VERSION = '1.302175'; + +require Test::Builder::Tester; + + +=head1 NAME + +Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester + +=head1 SYNOPSIS + + When running a test script + + perl -MTest::Builder::Tester::Color test.t + +=head1 DESCRIPTION + +Importing this module causes the subroutine color in Test::Builder::Tester +to be called with a true value causing colour highlighting to be turned +on in debug output. + +The sole purpose of this module is to enable colour highlighting +from the command line. + +=cut + +sub import { + Test::Builder::Tester::color(1); +} + +=head1 AUTHOR + +Copyright Mark Fowler Emark@twoshortplanks.comE 2002. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 BUGS + +This module will have no effect unless Term::ANSIColor is installed. + +=head1 SEE ALSO + +L, L + +=cut + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Builder/Tester.pm ddclient-3.10.0/t/lib/Test/Builder/Tester.pm --- ddclient-3.9.1/t/lib/Test/Builder/Tester.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/Tester.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,675 @@ +package Test::Builder::Tester; + +use strict; +our $VERSION = '1.302175'; + +use Test::Builder; +use Symbol; +use Carp; + +=head1 NAME + +Test::Builder::Tester - test testsuites that have been built with +Test::Builder + +=head1 SYNOPSIS + + use Test::Builder::Tester tests => 1; + use Test::More; + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=head1 DESCRIPTION + +A module that helps you test testing modules that are built with +L. + +The testing system is designed to be used by performing a three step +process for each test you wish to test. This process starts with using +C and C in advance to declare what the testsuite you +are testing will output with L to stdout and stderr. + +You then can run the test(s) from your test suite that call +L. At this point the output of L is +safely captured by L rather than being +interpreted as real test output. + +The final stage is to call C that will simply compare what you +predeclared to what L actually outputted, and report the +results back with a "ok" or "not ok" (with debugging) to the normal +output. + +=cut + +#### +# set up testing +#### + +my $t = Test::Builder->new; + +### +# make us an exporter +### + +use Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); + +sub import { + my $class = shift; + my(@plan) = @_; + + my $caller = caller; + + $t->exported_to($caller); + $t->plan(@plan); + + my @imports = (); + foreach my $idx ( 0 .. $#plan ) { + if( $plan[$idx] eq 'import' ) { + @imports = @{ $plan[ $idx + 1 ] }; + last; + } + } + + __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); +} + +### +# set up file handles +### + +# create some private file handles +my $output_handle = gensym; +my $error_handle = gensym; + +# and tie them to this package +my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; +my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; + +#### +# exported functions +#### + +# for remembering that we're testing and where we're testing at +my $testing = 0; +my $testing_num; +my $original_is_passing; + +# remembering where the file handles were originally connected +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; +my $original_formatter; + +my $original_harness_env; + +# function that starts testing and redirects the filehandles for now +sub _start_testing { + # Hack for things that conditioned on Test-Stream being loaded + $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; + # even if we're running under Test::Harness pretend we're not + # for now. This needed so Test::Builder doesn't add extra spaces + $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; + $ENV{HARNESS_ACTIVE} = 0; + + my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top); + $original_formatter = $hub->format; + unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { + my $fmt = Test::Builder::Formatter->new; + $hub->format($fmt); + } + + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($output_handle); + + # clear the expected list + $out->reset(); + $err->reset(); + + # remember that we're testing + $testing = 1; + $testing_num = $t->current_test; + $t->current_test(0); + $original_is_passing = $t->is_passing; + $t->is_passing(1); + + # look, we shouldn't do the ending stuff + $t->no_ending(1); +} + +=head2 Functions + +These are the six methods that are exported as default. + +=over 4 + +=item test_out + +=item test_err + +Procedures for predeclaring the output that your test suite is +expected to produce until C is called. These procedures +automatically assume that each line terminates with "\n". So + + test_out("ok 1","ok 2"); + +is the same as + + test_out("ok 1\nok 2"); + +which is even the same as + + test_out("ok 1"); + test_out("ok 2"); + +Once C or C (or C or C) have +been called, all further output from L will be +captured by L. This means that you will not +be able perform further tests to the normal output in the normal way +until you call C (well, unless you manually meddle with the +output filehandles) + +=cut + +sub test_out { + # do we need to do any setup? + _start_testing() unless $testing; + + $out->expect(@_); +} + +sub test_err { + # do we need to do any setup? + _start_testing() unless $testing; + + $err->expect(@_); +} + +=item test_fail + +Because the standard failure message that L produces +whenever a test fails will be a common occurrence in your test error +output, and because it has changed between Test::Builder versions, rather +than forcing you to call C with the string all the time like +so + + test_err("# Failed test ($0 at line ".line_num(+1).")"); + +C exists as a convenience function that can be called +instead. It takes one argument, the offset from the current line that +the line that causes the fail is on. + + test_fail(+1); + +This means that the example in the synopsis could be rewritten +more simply as: + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=cut + +sub test_fail { + # do we need to do any setup? + _start_testing() unless $testing; + + # work out what line we should be on + my( $package, $filename, $line ) = caller; + $line = $line + ( shift() || 0 ); # prevent warnings + + # expect that on stderr + $err->expect("# Failed test ($filename at line $line)"); +} + +=item test_diag + +As most of the remaining expected output to the error stream will be +created by L's C function, L +provides a convenience function C that you can use instead of +C. + +The C function prepends comment hashes and spacing to the +start and newlines to the end of the expected output passed to it and +adds it to the list of expected error output. So, instead of writing + + test_err("# Couldn't open file"); + +you can write + + test_diag("Couldn't open file"); + +Remember that L's diag function will not add newlines to +the end of output and test_diag will. So to check + + Test::Builder->new->diag("foo\n","bar\n"); + +You would do + + test_diag("foo","bar") + +without the newlines. + +=cut + +sub test_diag { + # do we need to do any setup? + _start_testing() unless $testing; + + # expect the same thing, but prepended with "# " + local $_; + $err->expect( map { "# $_" } @_ ); +} + +=item test_test + +Actually performs the output check testing the tests, comparing the +data (with C) that we have captured from L against +what was declared with C and C. + +This takes name/value pairs that effect how the test is run. + +=over + +=item title (synonym 'name', 'label') + +The name of the test that will be displayed after the C or C. + +=item skip_out + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the output stream does not match that +declared with C. + +=item skip_err + +Setting this to a true value will cause the test to ignore if the +output sent by the test to the error stream does not match that +declared with C. + +=back + +As a convenience, if only one argument is passed then this argument +is assumed to be the name of the test (as in the above examples.) + +Once C has been run test output will be redirected back to +the original filehandles that L was connected to +(probably STDOUT and STDERR,) meaning any further tests you run +will function normally and cause success/errors for L. + +=cut + +sub test_test { + # END the hack + delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; + # decode the arguments as described in the pod + my $mess; + my %args; + if( @_ == 1 ) { + $mess = shift + } + else { + %args = @_; + $mess = $args{name} if exists( $args{name} ); + $mess = $args{title} if exists( $args{title} ); + $mess = $args{label} if exists( $args{label} ); + } + + # er, are we testing? + croak "Not testing. You must declare output with a test function first." + unless $testing; + + + my $hub = $t->{Hub} || Test2::API::test2_stack->top; + $hub->format($original_formatter); + + # okay, reconnect the test suite back to the saved handles + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + + # restore the test no, etc, back to the original point + $t->current_test($testing_num); + $testing = 0; + $t->is_passing($original_is_passing); + + # re-enable the original setting of the harness + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # check the output we've stashed + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) + ) + { + # print out the diagnostic information about why this + # test failed + + local $_; + + $t->diag( map { "$_\n" } $out->complaint ) + unless $args{skip_out} || $out->check; + + $t->diag( map { "$_\n" } $err->complaint ) + unless $args{skip_err} || $err->check; + } +} + +=item line_num + +A utility function that returns the line number that the function was +called on. You can pass it an offset which will be added to the +result. This is very useful for working out the correct text of +diagnostic functions that contain line numbers. + +Essentially this is the same as the C<__LINE__> macro, but the +C idiom is arguably nicer. + +=cut + +sub line_num { + my( $package, $filename, $line ) = caller; + return $line + ( shift() || 0 ); # prevent warnings +} + +=back + +In addition to the six exported functions there exists one +function that can only be accessed with a fully qualified function +call. + +=over 4 + +=item color + +When C is called and the output that your tests generate +does not match that which you declared, C will print out +debug information showing the two conflicting versions. As this +output itself is debug information it can be confusing which part of +the output is from C and which was the original output from +your original tests. Also, it may be hard to spot things like +extraneous whitespace at the end of lines that may cause your test to +fail even though the output looks similar. + +To assist you C can colour the background of the debug +information to disambiguate the different types of output. The debug +output will have its background coloured green and red. The green +part represents the text which is the same between the executed and +actual output, the red shows which part differs. + +The C function determines if colouring should occur or not. +Passing it a true or false value will enable or disable colouring +respectively, and the function called with no argument will return the +current setting. + +To enable colouring from the command line, you can use the +L module like so: + + perl -Mlib=Text::Builder::Tester::Color test.t + +Or by including the L module directly in +the PERL5LIB. + +=cut + +my $color; + +sub color { + $color = shift if @_; + $color; +} + +=back + +=head1 BUGS + +Test::Builder::Tester does not handle plans well. It has never done anything +special with plans. This means that plans from outside Test::Builder::Tester +will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester +will effect overall testing. At this point there are no plans to fix this bug +as people have come to depend on it, and Test::Builder::Tester is now +discouraged in favor of C. See +L + +Calls C<< Test::Builder->no_ending >> turning off the ending tests. +This is needed as otherwise it will trip out because we've run more +tests than we strictly should have and it'll register any failures we +had that we were testing for as real failures. + +The color function doesn't work unless L is +compatible with your terminal. Additionally, L +must be installed on windows platforms for color output. + +Bugs (and requests for new features) can be reported to the author +though GitHub: +L + +=head1 AUTHOR + +Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. + +Some code taken from L and L, written by +Michael G Schwern Eschwern@pobox.comE. Hence, those parts +Copyright Micheal G Schwern 2001. Used and distributed with +permission. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 NOTES + +Thanks to Richard Clamp Erichardc@unixbeard.netE for letting +me use his testing system to try this module out on. + +=head1 SEE ALSO + +L, L, L. + +=cut + +1; + +#################################################################### +# Helper class that is used to remember expected and received data + +package Test::Builder::Tester::Tie; + +## +# add line(s) to be expected + +sub expect { + my $self = shift; + + my @checks = @_; + foreach my $check (@checks) { + $check = $self->_account_for_subtest($check); + $check = $self->_translate_Failed_check($check); + push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; + } +} + +sub _account_for_subtest { + my( $self, $check ) = @_; + + my $hub = $t->{Stack}->top; + my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; + return ref($check) ? $check : (' ' x $nesting) . $check; +} + +sub _translate_Failed_check { + my( $self, $check ) = @_; + + if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { + $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; + } + + return $check; +} + +## +# return true iff the expected data matches the got data + +sub check { + my $self = shift; + + # turn off warnings as these might be undef + local $^W = 0; + + my @checks = @{ $self->{wanted} }; + my $got = $self->{got}; + foreach my $check (@checks) { + $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); + return 0 unless $got =~ s/^$check//; + } + + return length $got == 0; +} + +## +# a complaint message about the inputs not matching (to be +# used for debugging messages) + +sub complaint { + my $self = shift; + my $type = $self->type; + my $got = $self->got; + my $wanted = join '', @{ $self->wanted }; + + # are we running in colour mode? + if(Test::Builder::Tester::color) { + # get color + eval { require Term::ANSIColor }; + unless($@) { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms + + # colours + + my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); + my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); + my $reset = Term::ANSIColor::color("reset"); + + # work out where the two strings start to differ + my $char = 0; + $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); + + # get the start string and the two end strings + my $start = $green . substr( $wanted, 0, $char ); + my $gotend = $red . substr( $got, $char ) . $reset; + my $wantedend = $red . substr( $wanted, $char ) . $reset; + + # make the start turn green on and off + $start =~ s/\n/$reset\n$green/g; + + # make the ends turn red on and off + $gotend =~ s/\n/$reset\n$red/g; + $wantedend =~ s/\n/$reset\n$red/g; + + # rebuild the strings + $got = $start . $gotend; + $wanted = $start . $wantedend; + } + } + + my @got = split "\n", $got; + my @wanted = split "\n", $wanted; + + $got = ""; + $wanted = ""; + + while (@got || @wanted) { + my $g = shift @got || ""; + my $w = shift @wanted || ""; + if ($g ne $w) { + if($g =~ s/(\s+)$/ |> /g) { + $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + if($w =~ s/(\s+)$/ |> /g) { + $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + $g = "> $g"; + $w = "> $w"; + } + else { + $g = " $g"; + $w = " $w"; + } + $got = $got ? "$got\n$g" : $g; + $wanted = $wanted ? "$wanted\n$w" : $w; + } + + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; +} + +## +# forget all expected and got data + +sub reset { + my $self = shift; + %$self = ( + type => $self->{type}, + got => '', + wanted => [], + ); +} + +sub got { + my $self = shift; + return $self->{got}; +} + +sub wanted { + my $self = shift; + return $self->{wanted}; +} + +sub type { + my $self = shift; + return $self->{type}; +} + +### +# tie interface +### + +sub PRINT { + my $self = shift; + $self->{got} .= join '', @_; +} + +sub TIEHANDLE { + my( $class, $type ) = @_; + + my $self = bless { type => $type }, $class; + + $self->reset; + + return $self; +} + +sub READ { } +sub READLINE { } +sub GETC { } +sub FILENO { } + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Builder/TodoDiag.pm ddclient-3.10.0/t/lib/Test/Builder/TodoDiag.pm --- ddclient-3.9.1/t/lib/Test/Builder/TodoDiag.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder/TodoDiag.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,68 @@ +package Test::Builder::TodoDiag; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } + +sub diagnostics { 0 } + +sub facet_data { + my $self = shift; + my $out = $self->SUPER::facet_data(); + $out->{info}->[0]->{debug} = 0; + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag + +=head1 DESCRIPTION + +This is used to encapsulate diag messages created inside TODO. + +=head1 SYNOPSIS + +You do not need to use this directly. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/Builder.pm ddclient-3.10.0/t/lib/Test/Builder.pm --- ddclient-3.9.1/t/lib/Test/Builder.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Builder.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,2608 @@ +package Test::Builder; + +use 5.006; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { + if( $] < 5.008 ) { + require Test::Builder::IO::Scalar; + } +} + +use Scalar::Util qw/blessed reftype weaken/; + +use Test2::Util qw/USE_THREADS try get_tid/; +use Test2::API qw/context release/; +# Make Test::Builder thread-safe for ithreads. +BEGIN { + warn "Test::Builder was loaded after Test2 initialization, this is not recommended." + if Test2::API::test2_init_done() || Test2::API::test2_load_done(); + + if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) { + require Test2::IPC; + require Test2::IPC::Driver::Files; + Test2::IPC::Driver::Files->import; + Test2::API::test2_ipc_enable_polling(); + Test2::API::test2_no_wait(1); + } +} + +use Test2::Event::Subtest; +use Test2::Hub::Subtest; + +use Test::Builder::Formatter; +use Test::Builder::TodoDiag; + +our $Level = 1; +our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; + +sub _add_ts_hooks { + my $self = shift; + + my $hub = $self->{Stack}->top; + + # Take a reference to the hash key, we do this to avoid closing over $self + # which is the singleton. We use a reference because the value could change + # in rare cases. + my $epkgr = \$self->{Exported_To}; + + #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); + + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; + + my $epkg = $$epkgr; + my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; + + no strict 'refs'; + no warnings 'once'; + my $todo; + $todo = ${"$cpkg\::TODO"} if $cpkg; + $todo = ${"$epkg\::TODO"} if $epkg && !$todo; + + return $e unless defined($todo); + return $e unless length($todo); + + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; + + $e->set_todo($todo) if $e->can('set_todo'); + $e->add_amnesty({tag => 'TODO', details => $todo}); + + # Set todo on ok's + if ($e->isa('Test2::Event::Ok')) { + $e->set_effective_pass(1); + + if (my $result = $e->get_meta(__PACKAGE__)) { + $result->{reason} ||= $todo; + $result->{type} ||= 'todo'; + $result->{ok} = 1; + } + } + + return $e; + }, inherit => 1); +} + +{ + no warnings; + INIT { + use warnings; + Test2::API::test2_load() unless Test2::API::test2_in_preload(); + } +} + +sub new { + my($class) = shift; + unless($Test) { + $Test = $class->create(singleton => 1); + + Test2::API::test2_add_callback_post_load( + sub { + $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; + $Test->reset(singleton => 1); + $Test->_add_ts_hooks; + } + ); + + # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So + # we only want the level to change if $Level != 1. + # TB->ctx compensates for this later. + Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); + + Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); + + Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc(); + } + return $Test; +} + +sub create { + my $class = shift; + my %params = @_; + + my $self = bless {}, $class; + if ($params{singleton}) { + $self->{Stack} = Test2::API::test2_stack(); + } + else { + $self->{Stack} = Test2::API::Stack->new; + $self->{Stack}->new_hub( + formatter => Test::Builder::Formatter->new, + ipc => Test2::API::test2_ipc(), + ); + + $self->reset(%params); + $self->_add_ts_hooks; + } + + return $self; +} + +sub ctx { + my $self = shift; + context( + # 1 for our frame, another for the -1 off of $Level in our hook at the top. + level => 2, + fudge => 1, + stack => $self->{Stack}, + hub => $self->{Hub}, + wrapped => 1, + @_ + ); +} + +sub parent { + my $self = shift; + my $ctx = $self->ctx; + my $chub = $self->{Hub} || $ctx->hub; + $ctx->release; + + my $meta = $chub->meta(__PACKAGE__, {}); + my $parent = $meta->{parent}; + + return undef unless $parent; + + return bless { + Original_Pid => $$, + Stack => $self->{Stack}, + Hub => $parent, + }, blessed($self); +} + +sub child { + my( $self, $name ) = @_; + + $name ||= "Child of " . $self->name; + my $ctx = $self->ctx; + + my $parent = $ctx->hub; + my $pmeta = $parent->meta(__PACKAGE__, {}); + $self->croak("You already have a child named ($pmeta->{child}) running") + if $pmeta->{child}; + + $pmeta->{child} = $name; + + # Clear $TODO for the child. + my $orig_TODO = $self->find_TODO(undef, 1, undef); + + my $subevents = []; + + my $hub = $ctx->stack->new_hub( + class => 'Test2::Hub::Subtest', + ); + + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; + + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; + + return $e; + }, inherit => 1) if $orig_TODO; + + $hub->listen(sub { push @$subevents => $_[1] }); + + $hub->set_nested( $parent->nested + 1 ); + + my $meta = $hub->meta(__PACKAGE__, {}); + $meta->{Name} = $name; + $meta->{TODO} = $orig_TODO; + $meta->{TODO_PKG} = $ctx->trace->package; + $meta->{parent} = $parent; + $meta->{Test_Results} = []; + $meta->{subevents} = $subevents; + $meta->{subtest_id} = $hub->id; + $meta->{subtest_uuid} = $hub->uuid; + $meta->{subtest_buffered} = $parent->format ? 0 : 1; + + $self->_add_ts_hooks; + + $ctx->release; + return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); +} + +sub finalize { + my $self = shift; + my $ok = 1; + ($ok) = @_ if @_; + + my $st_ctx = $self->ctx; + my $chub = $self->{Hub} || return $st_ctx->release; + + my $meta = $chub->meta(__PACKAGE__, {}); + if ($meta->{child}) { + $self->croak("Can't call finalize() with child ($meta->{child}) active"); + } + + local $? = 0; # don't fail if $subtests happened to set $? nonzero + + $self->{Stack}->pop($chub); + + $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); + + my $parent = $self->parent; + my $ctx = $parent->ctx; + my $trace = $ctx->trace; + delete $ctx->hub->meta(__PACKAGE__, {})->{child}; + + $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) + if $ok + && $chub->count + && !$chub->no_ending + && !$chub->ended; + + my $plan = $chub->plan || 0; + my $count = $chub->count; + my $failed = $chub->failed; + my $passed = $chub->is_passing; + + my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; + if ($count && $num_extra != 0) { + my $s = $plan == 1 ? '' : 's'; + $st_ctx->diag(<<"FAIL"); +Looks like you planned $plan test$s but ran $count. +FAIL + } + + if ($failed) { + my $s = $failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + + $st_ctx->diag(<<"FAIL"); +Looks like you failed $failed test$s of $count$qualifier. +FAIL + } + + if (!$passed && !$failed && $count && !$num_extra) { + $st_ctx->diag(<<"FAIL"); +All assertions inside the subtest passed, but errors were encountered. +FAIL + } + + $st_ctx->release; + + unless ($chub->bailed_out) { + my $plan = $chub->plan; + if ( $plan && $plan eq 'SKIP' ) { + $parent->skip($chub->skip_reason, $meta->{Name}); + } + elsif ( !$chub->count ) { + $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); + } + else { + $parent->{subevents} = $meta->{subevents}; + $parent->{subtest_id} = $meta->{subtest_id}; + $parent->{subtest_uuid} = $meta->{subtest_uuid}; + $parent->{subtest_buffered} = $meta->{subtest_buffered}; + $parent->ok( $chub->is_passing, $meta->{Name} ); + } + } + + $ctx->release; + return $chub->is_passing; +} + +sub subtest { + my $self = shift; + my ($name, $code, @args) = @_; + my $ctx = $self->ctx; + $ctx->throw("subtest()'s second argument must be a code ref") + unless $code && reftype($code) eq 'CODE'; + + $name ||= "Child of " . $self->name; + + + $_->($name,$code,@args) + for Test2::API::test2_list_pre_subtest_callbacks(); + + $ctx->note("Subtest: $name"); + + my $child = $self->child($name); + + my $start_pid = $$; + my $st_ctx; + my ($ok, $err, $finished, $child_error); + T2_SUBTEST_WRAPPER: { + my $ctx = $self->ctx; + $st_ctx = $ctx->snapshot; + $ctx->release; + $ok = eval { local $Level = 1; $code->(@args); 1 }; + ($err, $child_error) = ($@, $?); + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { + $ok = undef; + $err = undef; + } + else { + $finished = 1; + } + } + + if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } + + my $trace = $ctx->trace; + + if (!$finished) { + if(my $bailed = $st_ctx->hub->bailed_out) { + my $chub = $child->{Hub}; + $self->{Stack}->pop($chub); + $ctx->bail($bailed->reason); + } + my $code = $st_ctx->hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + + my $st_hub = $st_ctx->hub; + my $plan = $st_hub->plan; + my $count = $st_hub->count; + + if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { + $st_ctx->plan(0) unless defined $plan; + $st_ctx->diag('No tests run!'); + } + + $child->finalize($st_ctx->trace); + + $ctx->release; + + die $err unless $ok; + + $? = $child_error if defined $child_error; + + return $st_hub->is_passing; +} + +sub name { + my $self = shift; + my $ctx = $self->ctx; + release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; +} + +sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my ($self, %params) = @_; + + Test2::API::test2_unset_is_end(); + + # We leave this a global because it has to be localized and localizing + # hash keys is just asking for pain. Also, it was documented. + $Level = 1; + + $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 + unless $params{singleton}; + + $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + $ctx->release; + unless ($params{singleton}) { + $hub->reset_state(); + $hub->_tb_reset(); + } + + $ctx = $self->ctx; + + my $meta = $ctx->hub->meta(__PACKAGE__, {}); + %$meta = ( + Name => $0, + Ending => 0, + Done_Testing => undef, + Skip_All => 0, + Test_Results => [], + parent => $meta->{parent}, + ); + + $self->{Exported_To} = undef unless $params{singleton}; + + $self->{Orig_Handles} ||= do { + my $format = $ctx->hub->format; + my $out; + if ($format && $format->isa('Test2::Formatter::TAP')) { + $out = $format->handles; + } + $out ? [@$out] : []; + }; + + $self->use_numbers(1); + $self->no_header(0) unless $params{singleton}; + $self->no_ending(0) unless $params{singleton}; + $self->reset_outputs; + + $ctx->release; + + return; +} + + +my %plan_cmds = ( + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, +); + +sub plan { + my( $self, $cmd, $arg ) = @_; + + return unless $cmd; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + + $ctx->throw("You tried to plan twice") if $hub->plan; + + local $Level = $Level + 1; + + if( my $method = $plan_cmds{$cmd} ) { + local $Level = $Level + 1; + $self->$method($arg); + } + else { + my @args = grep { defined } ( $cmd, $arg ); + $ctx->throw("plan() doesn't understand @args"); + } + + release $ctx, 1; +} + + +sub _plan_tests { + my($self, $arg) = @_; + + my $ctx = $self->ctx; + + if($arg) { + local $Level = $Level + 1; + $self->expected_tests($arg); + } + elsif( !defined $arg ) { + $ctx->throw("Got an undefined number of tests"); + } + else { + $ctx->throw("You said to run 0 tests"); + } + + $ctx->release; +} + + +sub expected_tests { + my $self = shift; + my($max) = @_; + + my $ctx = $self->ctx; + + if(@_) { + $self->croak("Number of tests must be a positive integer. You gave it '$max'") + unless $max =~ /^\+?\d+$/; + + $ctx->plan($max); + } + + my $hub = $ctx->hub; + + $ctx->release; + + my $plan = $hub->plan; + return 0 unless $plan; + return 0 if $plan =~ m/\D/; + return $plan; +} + + +sub no_plan { + my($self, $arg) = @_; + + my $ctx = $self->ctx; + + if (defined $ctx->hub->plan) { + warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; + $ctx->release; + return; + } + + $ctx->alert("no_plan takes no arguments") if $arg; + + $ctx->hub->plan('NO PLAN'); + + release $ctx, 1; +} + + +sub done_testing { + my($self, $num_tests) = @_; + + my $ctx = $self->ctx; + + my $meta = $ctx->hub->meta(__PACKAGE__, {}); + + if ($meta->{Done_Testing}) { + my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; + local $ctx->hub->{ended}; # OMG This is awful. + $self->ok(0, "done_testing() was already called at $file line $line"); + $ctx->release; + return; + } + $meta->{Done_Testing} = [$ctx->trace->call]; + + my $plan = $ctx->hub->plan; + my $count = $ctx->hub->count; + + # If done_testing() specified the number of tests, shut off no_plan + if( defined $num_tests ) { + $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; + } + elsif ($count && defined $num_tests && $count != $num_tests) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); + } + else { + $num_tests = $self->current_test; + } + + if( $self->expected_tests && $num_tests != $self->expected_tests ) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". + "but done_testing() expects $num_tests"); + } + + $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; + + $ctx->hub->finalize($ctx->trace, 1); + + release $ctx, 1; +} + + +sub has_plan { + my $self = shift; + + my $ctx = $self->ctx; + my $plan = $ctx->hub->plan; + $ctx->release; + + return( $plan ) if $plan && $plan !~ m/\D/; + return('no_plan') if $plan && $plan eq 'NO PLAN'; + return(undef); +} + + +sub skip_all { + my( $self, $reason ) = @_; + + my $ctx = $self->ctx; + + $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; + + # Work around old perl bug + if ($] < 5.020000) { + my $begin = 0; + my $level = 0; + while (my @call = caller($level++)) { + last unless @call && $call[0]; + next unless $call[3] =~ m/::BEGIN$/; + $begin++; + last; + } + # HACK! + die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; + } + + $ctx->plan(0, SKIP => $reason); +} + + +sub exported_to { + my( $self, $pack ) = @_; + + if( defined $pack ) { + $self->{Exported_To} = $pack; + } + return $self->{Exported_To}; +} + + +sub ok { + my( $self, $test, $name ) = @_; + + my $ctx = $self->ctx; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + # In case $name is a string overloaded object, force it to stringify. + no warnings qw/uninitialized numeric/; + $name = "$name" if defined $name; + + # Profiling showed that the regex here was a huge time waster, doing the + # numeric addition first cuts our profile time from ~300ms to ~50ms + $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/; + You named your test '$name'. You shouldn't use numbers for your test names. + Very confusing. + ERR + use warnings qw/uninitialized numeric/; + + my $trace = $ctx->{trace}; + my $hub = $ctx->{hub}; + + my $result = { + ok => $test, + actual_ok => $test, + reason => '', + type => '', + (name => defined($name) ? $name : ''), + }; + + $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; + + my $orig_name = $name; + + my @attrs; + my $subevents = delete $self->{subevents}; + my $subtest_id = delete $self->{subtest_id}; + my $subtest_uuid = delete $self->{subtest_uuid}; + my $subtest_buffered = delete $self->{subtest_buffered}; + my $epkg = 'Test2::Event::Ok'; + if ($subevents) { + $epkg = 'Test2::Event::Subtest'; + push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered); + } + + my $e = bless { + trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), + pass => $test, + name => $name, + _meta => {'Test::Builder' => $result}, + effective_pass => $test, + @attrs, + }, $epkg; + $hub->send($e); + + $self->_ok_debug($trace, $orig_name) unless($test); + + $ctx->release; + return $test; +} + +sub _ok_debug { + my $self = shift; + my ($trace, $orig_name) = @_; + + my $is_todo = $self->in_todo; + + my $msg = $is_todo ? "Failed (TODO)" : "Failed"; + + my (undef, $file, $line) = $trace->call; + if (defined $orig_name) { + $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } +} + +sub _diag_fh { + my $self = shift; + local $Level = $Level + 1; + return $self->in_todo ? $self->todo_output : $self->failure_output; +} + +sub _unoverload { + my ($self, $type, $thing) = @_; + + return unless ref $$thing; + return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); + { + local ($!, $@); + require overload; + } + my $string_meth = overload::Method( $$thing, $type ) || return; + $$thing = $$thing->$string_meth(); +} + +sub _unoverload_str { + my $self = shift; + + $self->_unoverload( q[""], $_ ) for @_; +} + +sub _unoverload_num { + my $self = shift; + + $self->_unoverload( '0+', $_ ) for @_; + + for my $val (@_) { + next unless $self->_is_dualvar($$val); + $$val = $$val + 0; + } +} + +# This is a hack to detect a dualvar such as $! +sub _is_dualvar { + my( $self, $val ) = @_; + + # Objects are not dualvars. + return 0 if ref $val; + + no warnings 'numeric'; + my $numval = $val + 0; + return ($numval != 0 and $numval ne $val ? 1 : 0); +} + + +sub is_eq { + my( $self, $got, $expect, $name ) = @_; + + my $ctx = $self->ctx; + + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok( $test, $name ); + $self->_is_diag( $got, 'eq', $expect ) unless $test; + $ctx->release; + return $test; + } + + release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); +} + + +sub is_num { + my( $self, $got, $expect, $name ) = @_; + my $ctx = $self->ctx; + local $Level = $Level + 1; + + if( !defined $got || !defined $expect ) { + # undef only matches undef and nothing else + my $test = !defined $got && !defined $expect; + + $self->ok( $test, $name ); + $self->_is_diag( $got, '==', $expect ) unless $test; + $ctx->release; + return $test; + } + + release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); +} + + +sub _diag_fmt { + my( $self, $type, $val ) = @_; + + if( defined $$val ) { + if( $type eq 'eq' or $type eq 'ne' ) { + # quote and force string context + $$val = "'$$val'"; + } + else { + # force numeric context + $self->_unoverload_num($val); + } + } + else { + $$val = 'undef'; + } + + return; +} + + +sub _is_diag { + my( $self, $got, $type, $expect ) = @_; + + $self->_diag_fmt( $type, $_ ) for \$got, \$expect; + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + got: $got + expected: $expect +DIAGNOSTIC + +} + +sub _isnt_diag { + my( $self, $got, $type ) = @_; + + $self->_diag_fmt( $type, \$got ); + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + got: $got + expected: anything else +DIAGNOSTIC +} + + +sub isnt_eq { + my( $self, $got, $dont_expect, $name ) = @_; + my $ctx = $self->ctx; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok( $test, $name ); + $self->_isnt_diag( $got, 'ne' ) unless $test; + $ctx->release; + return $test; + } + + release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); +} + +sub isnt_num { + my( $self, $got, $dont_expect, $name ) = @_; + my $ctx = $self->ctx; + local $Level = $Level + 1; + + if( !defined $got || !defined $dont_expect ) { + # undef only matches undef and nothing else + my $test = defined $got || defined $dont_expect; + + $self->ok( $test, $name ); + $self->_isnt_diag( $got, '!=' ) unless $test; + $ctx->release; + return $test; + } + + release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); +} + + +sub like { + my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; + + local $Level = $Level + 1; + + release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); +} + +sub unlike { + my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; + + local $Level = $Level + 1; + + release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); +} + + +my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); + +# Bad, these are not comparison operators. Should we include more? +my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); + +sub cmp_ok { + my( $self, $got, $type, $expect, $name ) = @_; + my $ctx = $self->ctx; + + if ($cmp_ok_bl{$type}) { + $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); + } + + my ($test, $succ); + my $error; + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + my($pack, $file, $line) = $ctx->trace->call(); + + # This is so that warnings come out at the caller's level + $succ = eval qq[ +#line $line "(eval in cmp_ok) $file" +\$test = (\$got $type \$expect); +1; +]; + $error = $@; + } + local $Level = $Level + 1; + my $ok = $self->ok( $test, $name ); + + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload + = $numeric_cmps{$type} + ? '_unoverload_num' + : '_unoverload_str'; + + $self->diag(<<"END") unless $succ; +An error occurred while using $type: +------------------------------------ +$error +------------------------------------ +END + + unless($ok) { + $self->$unoverload( \$got, \$expect ); + + if( $type =~ /^(eq|==)$/ ) { + $self->_is_diag( $got, $type, $expect ); + } + elsif( $type =~ /^(ne|!=)$/ ) { + no warnings; + my $eq = ($got eq $expect || $got == $expect) + && ( + (defined($got) xor defined($expect)) + || (length($got) != length($expect)) + ); + use warnings; + + if ($eq) { + $self->_cmp_diag( $got, $type, $expect ); + } + else { + $self->_isnt_diag( $got, $type ); + } + } + else { + $self->_cmp_diag( $got, $type, $expect ); + } + } + return release $ctx, $ok; +} + +sub _cmp_diag { + my( $self, $got, $type, $expect ) = @_; + + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + $got + $type + $expect +DIAGNOSTIC +} + +sub _caller_context { + my $self = shift; + + my( $pack, $file, $line ) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + return $code; +} + + +sub BAIL_OUT { + my( $self, $reason ) = @_; + + my $ctx = $self->ctx; + + $self->{Bailed_Out} = 1; + + $ctx->bail($reason); +} + + +{ + no warnings 'once'; + *BAILOUT = \&BAIL_OUT; +} + +sub skip { + my( $self, $why, $name ) = @_; + $why ||= ''; + $name = '' unless defined $name; + $self->_unoverload_str( \$why ); + + my $ctx = $self->ctx; + + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 1, + name => $name, + type => 'skip', + reason => $why, + } unless $self->{no_log_results}; + + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $name =~ s{\n}{\n# }sg; + $why =~ s{\n}{\n# }sg; + + my $tctx = $ctx->snapshot; + $tctx->skip('', $why); + + return release $ctx, 1; +} + + +sub todo_skip { + my( $self, $why ) = @_; + $why ||= ''; + + my $ctx = $self->ctx; + + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + } unless $self->{no_log_results}; + + $why =~ s{\n}{\n# }sg; + my $tctx = $ctx->snapshot; + $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); + + return release $ctx, 1; +} + + +sub maybe_regex { + my( $self, $regex ) = @_; + my $usable_regex = undef; + + return $usable_regex unless defined $regex; + + my( $re, $opts ); + + # Check for qr/foo/ + if( _is_qr($regex) ) { + $usable_regex = $regex; + } + # Check for '/foo/' or 'm,foo,' + elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or + ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx + ) + { + $usable_regex = length $opts ? "(?$opts)$re" : $re; + } + + return $usable_regex; +} + +sub _is_qr { + my $regex = shift; + + # is_regexp() checks for regexes in a robust manner, say if they're + # blessed. + return re::is_regexp($regex) if defined &re::is_regexp; + return ref $regex eq 'Regexp'; +} + +sub _regex_ok { + my( $self, $thing, $regex, $cmp, $name ) = @_; + + my $ok = 0; + my $usable_regex = $self->maybe_regex($regex); + unless( defined $usable_regex ) { + local $Level = $Level + 1; + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); + return $ok; + } + + { + my $test; + my $context = $self->_caller_context; + + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + + local( $@, $!, $SIG{__DIE__} ); # isolate eval + + # No point in issuing an uninit warning, they'll see it in the diagnostics + no warnings 'uninitialized'; + + $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; + } + + $test = !$test if $cmp eq '!~'; + + local $Level = $Level + 1; + $ok = $self->ok( $test, $name ); + } + + unless($ok) { + $thing = defined $thing ? "'$thing'" : 'undef'; + my $match = $cmp eq '=~' ? "doesn't match" : "matches"; + + local $Level = $Level + 1; + $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); + %s + %13s '%s' +DIAGNOSTIC + + } + + return $ok; +} + + +sub is_fh { + my $self = shift; + my $maybe_fh = shift; + return 0 unless defined $maybe_fh; + + return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return eval { $maybe_fh->isa("IO::Handle") } || + eval { tied($maybe_fh)->can('TIEHANDLE') }; +} + + +sub level { + my( $self, $level ) = @_; + + if( defined $level ) { + $Level = $level; + } + return $Level; +} + + +sub use_numbers { + my( $self, $use_nums ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { + warn "The current formatter does not support 'use_numbers'" if $format; + return release $ctx, 0; + } + + $format->set_no_numbers(!$use_nums) if defined $use_nums; + + return release $ctx, $format->no_numbers ? 0 : 1; +} + +BEGIN { + for my $method (qw(no_header no_diag)) { + my $set = "set_$method"; + my $code = sub { + my( $self, $no ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + unless ($format && $format->can($set)) { + warn "The current formatter does not support '$method'" if $format; + $ctx->release; + return + } + + $format->$set($no) if defined $no; + + return release $ctx, $format->$method ? 1 : 0; + }; + + no strict 'refs'; ## no critic + *$method = $code; + } +} + +sub no_ending { + my( $self, $no ) = @_; + + my $ctx = $self->ctx; + + $ctx->hub->set_no_ending($no) if defined $no; + + return release $ctx, $ctx->hub->no_ending; +} + +sub diag { + my $self = shift; + return unless @_; + + my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; + + if (Test2::API::test2_in_preload()) { + chomp($text); + $text =~ s/^/# /msg; + print STDERR $text, "\n"; + return 0; + } + + my $ctx = $self->ctx; + $ctx->diag($text); + $ctx->release; + return 0; +} + + +sub note { + my $self = shift; + return unless @_; + + my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; + + if (Test2::API::test2_in_preload()) { + chomp($text); + $text =~ s/^/# /msg; + print STDOUT $text, "\n"; + return 0; + } + + my $ctx = $self->ctx; + $ctx->note($text); + $ctx->release; + return 0; +} + + +sub explain { + my $self = shift; + + local ($@, $!); + require Data::Dumper; + + return map { + ref $_ + ? do { + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; +} + + +sub output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + + $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; +} + +sub failure_output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + + $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; +} + +sub todo_output { + my( $self, $fh ) = @_; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test::Builder::Formatter'); + + $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) + if defined $fh; + + return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; +} + +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; + + my $fh; + if( $self->is_fh($file_or_fh) ) { + $fh = $file_or_fh; + } + elsif( ref $file_or_fh eq 'SCALAR' ) { + # Scalar refs as filehandles was added in 5.8. + if( $] >= 5.008 ) { + open $fh, ">>", $file_or_fh + or $self->croak("Can't open scalar ref $file_or_fh: $!"); + } + # Emulate scalar ref filehandles with a tie. + else { + $fh = Test::Builder::IO::Scalar->new($file_or_fh) + or $self->croak("Can't tie scalar ref $file_or_fh"); + } + } + else { + open $fh, ">", $file_or_fh + or $self->croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); + } + + return $fh; +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; +} + + +sub reset_outputs { + my $self = shift; + + my $ctx = $self->ctx; + my $format = $ctx->hub->format; + $ctx->release; + return unless $format && $format->isa('Test2::Formatter::TAP'); + $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; + + return; +} + + +sub carp { + my $self = shift; + my $ctx = $self->ctx; + $ctx->alert(join "", @_); + $ctx->release; +} + +sub croak { + my $self = shift; + my $ctx = $self->ctx; + $ctx->throw(join "", @_); + $ctx->release; +} + + +sub current_test { + my( $self, $num ) = @_; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + + if( defined $num ) { + $hub->set_count($num); + + unless ($self->{no_log_results}) { + # If the test counter is being pushed forward fill in the details. + my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + if ($num > @$test_results) { + my $start = @$test_results ? @$test_results : 0; + for ($start .. $num - 1) { + $test_results->[$_] = { + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + }; + } + } + # If backward, wipe history. Its their funeral. + elsif ($num < @$test_results) { + $#{$test_results} = $num - 1; + } + } + } + return release $ctx, $hub->count; +} + + +sub is_passing { + my $self = shift; + + my $ctx = $self->ctx; + my $hub = $ctx->hub; + + if( @_ ) { + my ($bool) = @_; + $hub->set_failed(0) if $bool; + $hub->is_passing($bool); + } + + return release $ctx, $hub->is_passing; +} + + +sub summary { + my($self) = shift; + + return if $self->{no_log_results}; + + my $ctx = $self->ctx; + my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + $ctx->release; + return map { $_ ? $_->{'ok'} : () } @$data; +} + + +sub details { + my $self = shift; + + return if $self->{no_log_results}; + + my $ctx = $self->ctx; + my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + $ctx->release; + return @$data; +} + + +sub find_TODO { + my( $self, $pack, $set, $new_value ) = @_; + + my $ctx = $self->ctx; + + $pack ||= $ctx->trace->package || $self->exported_to; + $ctx->release; + + return unless $pack; + + no strict 'refs'; ## no critic + no warnings 'once'; + my $old_value = ${ $pack . '::TODO' }; + $set and ${ $pack . '::TODO' } = $new_value; + return $old_value; +} + +sub todo { + my( $self, $pack ) = @_; + + local $Level = $Level + 1; + my $ctx = $self->ctx; + $ctx->release; + + my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; + return $meta->[-1]->[1] if $meta && @$meta; + + $pack ||= $ctx->trace->package; + + return unless $pack; + + no strict 'refs'; ## no critic + no warnings 'once'; + return ${ $pack . '::TODO' }; +} + +sub in_todo { + my $self = shift; + + local $Level = $Level + 1; + my $ctx = $self->ctx; + $ctx->release; + + my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; + return 1 if $meta && @$meta; + + my $pack = $ctx->trace->package || return 0; + + no strict 'refs'; ## no critic + no warnings 'once'; + my $todo = ${ $pack . '::TODO' }; + + return 0 unless defined $todo; + return 0 if "$todo" eq ''; + return 1; +} + +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; + + my $ctx = $self->ctx; + + my $hub = $ctx->hub; + my $filter = $hub->pre_filter(sub { + my ($active_hub, $e) = @_; + + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { + $e->set_todo($message); + $e->set_effective_pass(1); + + if (my $result = $e->get_meta(__PACKAGE__)) { + $result->{reason} ||= $message; + $result->{type} ||= 'todo'; + $result->{ok} = 1; + } + } + + return $e; + }, inherit => 1); + + push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; + + $ctx->release; + + return; +} + +sub todo_end { + my $self = shift; + + my $ctx = $self->ctx; + + my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; + + $ctx->throw('todo_end() called without todo_start()') unless $set; + + $ctx->hub->pre_unfilter($set->[0]); + + $ctx->release; + + return; +} + + +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self ) = @_; + + my $ctx = $self->ctx; + + my $trace = $ctx->trace; + $ctx->release; + return wantarray ? $trace->call : $trace->package; +} + + +sub _try { + my( $self, $code, %opts ) = @_; + + my $error; + my $return; + { + local $!; # eval can mess up $! + local $@; # don't set $@ in the test + local $SIG{__DIE__}; # don't trip an outside DIE handler. + $return = eval { $code->() }; + $error = $@; + } + + die $error if $error and $opts{die_on_fail}; + + return wantarray ? ( $return, $error ) : $return; +} + +sub _ending { + my $self = shift; + my ($ctx, $real_exit_code, $new) = @_; + + unless ($ctx) { + my $octx = $self->ctx; + $ctx = $octx->snapshot; + $octx->release; + } + + return if $ctx->hub->no_ending; + return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + return unless $self->{Original_Pid} == $$; + + my $hub = $ctx->hub; + return if $hub->bailed_out; + + my $plan = $hub->plan; + my $count = $hub->count; + my $failed = $hub->failed; + my $passed = $hub->is_passing; + return unless $plan || $count || $failed; + + # Ran tests but never declared a plan or hit done_testing + if( !$hub->plan and $hub->count ) { + $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); + + if($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $count. +FAIL + $$new ||= $real_exit_code; + return; + } + + # But if the tests ran, handle exit code. + if($failed > 0) { + my $exit_code = $failed <= 254 ? $failed : 254; + $$new ||= $exit_code; + return; + } + + $$new ||= 254; + return; + } + + if ($real_exit_code && !$count) { + $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); + $$new ||= $real_exit_code; + return; + } + + return if $plan && "$plan" eq 'SKIP'; + + if (!$count) { + $self->diag('No tests run!'); + $$new ||= 255; + return; + } + + if ($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code just after $count. +FAIL + $$new ||= $real_exit_code; + return; + } + + if ($plan eq 'NO PLAN') { + $ctx->plan( $count ); + $plan = $hub->plan; + } + + # Figure out if we passed or failed and print helpful messages. + my $num_extra = $count - $plan; + + if ($num_extra != 0) { + my $s = $plan == 1 ? '' : 's'; + $self->diag(<<"FAIL"); +Looks like you planned $plan test$s but ran $count. +FAIL + } + + if ($failed) { + my $s = $failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + + $self->diag(<<"FAIL"); +Looks like you failed $failed test$s of $count$qualifier. +FAIL + } + + if (!$passed && !$failed && $count && !$num_extra) { + $ctx->diag(<<"FAIL"); +All assertions passed, but errors were encountered. +FAIL + } + + my $exit_code = 0; + if ($failed) { + $exit_code = $failed <= 254 ? $failed : 254; + } + elsif ($num_extra != 0) { + $exit_code = 255; + } + elsif (!$passed) { + $exit_code = 255; + } + + $$new ||= $exit_code; + return; +} + +# Some things used this even though it was private... I am looking at you +# Test::Builder::Prefix... +sub _print_comment { + my( $self, $fh, @msgs ) = @_; + + return if $self->no_diag; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + # Smash args together like print does. + # Convert undef to 'undef' so its readable. + my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; + + # Escape the beginning, _print will take care of the rest. + $msg =~ s/^/# /; + + local( $\, $", $, ) = ( undef, ' ', '' ); + print $fh $msg; + + return 0; +} + +# This is used by Test::SharedFork to turn on IPC after the fact. Not +# documenting because I do not want it used. The method name is borrowed from +# Test::Builder 2 +# Once Test2 stuff goes stable this method will be removed and Test::SharedFork +# will be made smarter. +sub coordinate_forks { + my $self = shift; + + { + local ($@, $!); + require Test2::IPC; + } + Test2::IPC->import; + Test2::API::test2_ipc_enable_polling(); + Test2::API::test2_load(); + my $ipc = Test2::IPC::apply_ipc($self->{Stack}); + $ipc->set_no_fatal(1); + Test2::API::test2_no_wait(1); +} + +sub no_log_results { $_[0]->{no_log_results} = 1 } + +1; + +__END__ + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use base 'Test::Builder::Module'; + + my $CLASS = __PACKAGE__; + + sub ok { + my($test, $name) = @_; + my $tb = $CLASS->builder; + + $tb->ok($test, $name); + } + + +=head1 DESCRIPTION + +L and L have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides a +building block upon which to write your own test libraries I. + +=head2 Construction + +=over 4 + +=item B + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program C always returns the same +Test::Builder object. No matter how many times you call C, you're +getting the same object. This is called a singleton. This is done so that +multiple modules share such global information as the test counter and +where test output is going. + +If you want a completely new Test::Builder object different from the +singleton, use C. + +=item B + + my $Test = Test::Builder->create; + +Ok, so there can be more than one Test::Builder object and this is how +you get it. You might use this instead of C if you're testing +a Test::Builder based module, but otherwise you probably want C. + +B: the implementation is not complete. C, for example, is still +shared by B Test::Builder objects, even ones created using this method. +Also, the method name may change in the future. + +=item B + + $builder->subtest($name, \&subtests, @args); + +See documentation of C in Test::More. + +C also, and optionally, accepts arguments which will be passed to the +subtests reference. + +=item B + + diag $builder->name; + +Returns the name of the current builder. Top level builders default to C<$0> +(the name of the executable). Child builders are named via the C +method. If no name is supplied, will be named "Child of $parent->name". + +=item B + + $Test->reset; + +Reinitializes the Test::Builder singleton to its original state. +Mostly useful for tests run in persistent environments where the same +test might be run multiple times in the same process. + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call C, don't call any of the other methods below. + +=item B + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the number of tests we expect this test to run and prints out +the appropriate headers. + + +=item B + + $Test->no_plan; + +Declares that this test will run an indeterminate number of tests. + + +=item B + + $Test->done_testing(); + $Test->done_testing($num_tests); + +Declares that you are done testing, no more tests will be run after this point. + +If a plan has not yet been output, it will do so. + +$num_tests is the number of tests you planned to run. If a numbered +plan was already declared, and if this contradicts, a failing test +will be run to reflect the planning mistake. If C was declared, +this will override. + +If C is called twice, the second call will issue a +failing test. + +If C<$num_tests> is omitted, the number of tests run will be used, like +no_plan. + +C is, in effect, used when you'd want to use C, but +safer. You'd use it like so: + + $Test->ok($a == $b); + $Test->done_testing(); + +Or to plan a variable number of tests: + + for my $test (@tests) { + $Test->ok($test); + } + $Test->done_testing(scalar @tests); + + +=item B + + $plan = $Test->has_plan + +Find out whether a plan has been defined. C<$plan> is either C (no plan +has been set), C (indeterminate # of tests) or an integer (the number +of expected tests). + +=item B + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given C<$reason>. Exits immediately with 0. + +=item B + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. + +This method isn't terribly useful since modules which share the same +Test::Builder object might get exported to different packages and only +the last one will be honored. + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in Test::More. + +They all return true if the test passed, false if the test failed. + +C<$name> is always optional. + +=over 4 + +=item B + + $Test->ok($test, $name); + +Your basic test. Pass if C<$test> is true, fail if $test is false. Just +like Test::Simple's C. + +=item B + + $Test->is_eq($got, $expected, $name); + +Like Test::More's C. Checks if C<$got eq $expected>. This is the +string version. + +C only ever matches another C. + +=item B + + $Test->is_num($got, $expected, $name); + +Like Test::More's C. Checks if C<$got == $expected>. This is the +numeric version. + +C only ever matches another C. + +=item B + + $Test->isnt_eq($got, $dont_expect, $name); + +Like L's C. Checks if C<$got ne $dont_expect>. This is +the string version. + +=item B + + $Test->isnt_num($got, $dont_expect, $name); + +Like L's C. Checks if C<$got ne $dont_expect>. This is +the numeric version. + +=item B + + $Test->like($thing, qr/$regex/, $name); + $Test->like($thing, '/$regex/', $name); + +Like L's C. Checks if $thing matches the given C<$regex>. + +=item B + + $Test->unlike($thing, qr/$regex/, $name); + $Test->unlike($thing, '/$regex/', $name); + +Like L's C. Checks if $thing B the +given C<$regex>. + +=item B + + $Test->cmp_ok($thing, $type, $that, $name); + +Works just like L's C. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=back + +=head2 Other Testing Methods + +These are methods which are used in the course of writing a test but are not themselves tests. + +=over 4 + +=item B + + $Test->BAIL_OUT($reason); + +Indicates to the L that things are going so badly all +testing should terminate. This includes running any additional test +scripts. + +It will exit with 255. + +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=item B + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=item B + + $Test->todo_skip; + $Test->todo_skip($why); + +Like C, only it will declare the test as failing and TODO. Similar +to + + print "not ok $tnum # TODO $why\n"; + +=begin _unimplemented + +=item B + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like C, only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under C, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test building utility methods + +These methods are useful when writing your own test methods. + +=over 4 + +=item B + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +This method used to be useful back when Test::Builder worked on Perls +before 5.6 which didn't have qr//. Now its pretty useless. + +Convenience method for building testing functions that take regular +expressions as arguments. + +Takes a quoted regular expression produced by C, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or C if its argument is not recognized. + +For example, a version of C, sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $thing, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($thing =~ m/$usable_regex/, $name); + } + + +=item B + + my $is_fh = $Test->is_fh($thing); + +Determines if the given C<$thing> can be used as a filehandle. + +=cut + + +=back + + +=head2 Test style + + +=over 4 + +=item B + + $Test->level($how_high); + +How far up the call stack should C<$Test> look when reporting where the +test failed. + +Defaults to 1. + +Setting C<$Test::Builder::Level> overrides. This is typically useful +localized: + + sub my_ok { + my $test = shift; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->ok($test); + } + +To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. + +=item B + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Defaults to on. + +=item B + + $Test->no_diag($no_diag); + +If set true no diagnostics will be printed. This includes calls to +C. + +=item B + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described below. + +If this is true, none of that will be done. + +=item B + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=back + +=head2 Output + +Controlling where the test output goes. + +It's ok for your test to change where STDOUT and STDERR point to, +Test::Builder's default output settings will not be affected. + +=over 4 + +=item B + + $Test->diag(@msgs); + +Prints out the given C<@msgs>. Like C, arguments are simply +appended together. + +Normally, it uses the C handle, but if this is for a +TODO test, the C handle is used. + +Output will be indented and marked with a # so as not to interfere +with test output. A newline will be put on the end if there isn't one +already. + +We encourage using this rather than calling print directly. + +Returns false. Why? Because C is often used in conjunction with +a failing test (C) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler + +=item B + + $Test->note(@msgs); + +Like C, but it prints to the C handle so it will not +normally be seen by the user except in verbose mode. + +=item B + + my @dump = $Test->explain(@msgs); + +Will dump the contents of any references in a human readable format. +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + is_deeply($have, $want) || note explain $have; + +=item B + +=item B + +=item B + + my $filehandle = $Test->output; + $Test->output($filehandle); + $Test->output($filename); + $Test->output(\$scalar); + +These methods control where Test::Builder will print its output. +They take either an open C<$filehandle>, a C<$filename> to open and write to +or a C<$scalar> reference to append to. It will always return a C<$filehandle>. + +B is where normal "ok/not ok" test output goes. + +Defaults to STDOUT. + +B is where diagnostic output on test failures and +C goes. It is normally not read by Test::Harness and instead is +displayed to the user. + +Defaults to STDERR. + +C is used instead of C for the +diagnostics of a failing TODO test. These will not be seen by the +user. + +Defaults to STDOUT. + +=item reset_outputs + + $tb->reset_outputs; + +Resets all the output filehandles back to their defaults. + +=item carp + + $tb->carp(@message); + +Warns with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + +=item croak + + $tb->croak(@message); + +Dies with C<@message> but the message will appear to come from the +point where the original test function was called (C<< $tb->caller >>). + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B + +This will turn off result long-term storage. Calling this method will make +C
and C useless. You may want to use this if you are running +enough tests to fill up all available memory. + + Test::Builder->new->no_log_results(); + +There is no way to turn it back on. + +=item B + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test number we're on. You usually shouldn't +have to set this. + +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. + + +=item B + + my $ok = $builder->is_passing; + +Indicates if the test suite is currently passing. + +More formally, it will be false if anything has happened which makes +it impossible for the test suite to pass. True otherwise. + +For example, if no tests have run C will be true because +even though a suite with no tests is a failure you can add a passing +test to it and start passing. + +Don't think about it too much. + + +=item B + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + + +=item B
+ + my @tests = $Test->details; + +Like C, but with a lot more detail. + + $tests[$test_num - 1] = + { 'ok' => is the test considered a pass? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => type of test (if any, see below). + reason => reason for the above (if any) + }; + +'ok' is true if Test::Harness will consider the test to be a pass. + +'actual_ok' is a reflection of whether or not the test literally +printed 'ok' or 'not ok'. This is for examining the result of 'todo' +tests. + +'name' is the name of the test. + +'type' indicates if it was a special test. Normal tests have a type +of ''. Type can be one of the following: + + skip see skip() + todo see todo() + todo_skip see todo_skip() + unknown see below + +Sometimes the Test::Builder test counter is incremented without it +printing any test output, for example, when C is changed. +In these cases, Test::Builder doesn't know the result of the test, so +its type is 'unknown'. These details for these tests are filled in. +They are considered ok, but the name and actual_ok is left C. + +For example "not ok 23 - hole count # TODO insufficient donuts" would +result in this structure: + + $tests[22] = # 23 - 1, since arrays start from 0. + { ok => 1, # logically, the test passed since its todo + actual_ok => 0, # in absolute terms, it failed + name => 'hole count', + type => 'todo', + reason => 'insufficient donuts' + }; + + +=item B + + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); + +If the current tests are considered "TODO" it will return the reason, +if any. This reason can come from a C<$TODO> variable or the last call +to C. + +Since a TODO test does not need a reason, this function can return an +empty string even when inside a TODO block. Use C<< $Test->in_todo >> +to determine if you are currently inside a TODO block. + +C is about finding the right package to look for C<$TODO> in. It's +pretty good at guessing the right package to look at. It first looks for +the caller based on C<$Level + 1>, since C is usually called inside +a test function. As a last resort it will use C. + +Sometimes there is some confusion about where C should be looking +for the C<$TODO> variable. If you want to be sure, tell it explicitly +what $pack to use. + +=item B + + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack); + +Like C but only returns the value of C<$TODO> ignoring +C. + +Can also be used to set C<$TODO> to a new value while returning the +old value: + + my $old_reason = $Test->find_TODO($pack, 1, $new_reason); + +=item B + + my $in_todo = $Test->in_todo; + +Returns true if the test is currently inside a TODO block. + +=item B + + $Test->todo_start(); + $Test->todo_start($message); + +This method allows you declare all subsequent tests as TODO tests, up until +the C method has been called. + +The C and C<$TODO> syntax is generally pretty good about figuring out +whether or not we're in a TODO test. However, often we find that this is not +possible to determine (such as when we want to use C<$TODO> but +the tests are being executed in other packages which can't be inferred +beforehand). + +Note that you can use this to nest "todo" tests + + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + +This is generally not recommended, but large testing systems often have weird +internal needs. + +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: + + TODO: { + local $TODO = 'We have work to do!'; + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + } + +Pick one style or another of "TODO" to be on the safe side. + + +=item C + + $Test->todo_end; + +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C method call. + +=item B + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal C, except it reports according to your C. + +C<$height> will be added to the C. + +If C winds up off the top of the stack it report the highest context. + +=back + +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +=head1 THREADS + +In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is +shared by all threads. This means if one thread sets the test number using +C they will all be effected. + +While versions earlier than 5.8.1 had threads they contain too many +bugs to support. + +Test::Builder is only thread-aware if threads.pm is loaded I +Test::Builder. + +You can directly disable thread support with one of the following: + + $ENV{T2_NO_IPC} = 1 + +or + + no Test2::IPC; + +or + + Test2::API::test2_ipc_disable() + +=head1 MEMORY + +An informative hash, accessible via C, is stored for each +test you perform. So memory usage will scale linearly with each test +run. Although this is not a problem for most test suites, it can +become an issue if you do large (hundred thousands to million) +combinatorics tests in the same run. + +In such cases, you are advised to either split the test file into smaller +ones, or use a reverse approach, doing "normal" (code) compares and +triggering C should anything go unexpected. + +Future versions of Test::Builder will have a way to turn history off. + + +=head1 EXAMPLES + +CPAN can provide the best examples. L, L, +L and L all use Test::Builder. + +=head1 SEE ALSO + +=head2 INTERNALS + +L, L + +=head2 LEGACY + +L, L + +=head2 EXTERNAL + +L + +=head1 AUTHORS + +Original code by chromatic, maintained by Michael G Schwern +Eschwern@pobox.comE + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and + Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F diff -Nru ddclient-3.9.1/t/lib/Test/More.pm ddclient-3.10.0/t/lib/Test/More.pm --- ddclient-3.9.1/t/lib/Test/More.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/More.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,1997 @@ +package Test::More; + +use 5.006; +use strict; +use warnings; + +#---- perlcritic exemptions. ----# + +# We use a lot of subroutine prototypes +## no critic (Subroutines::ProhibitSubroutinePrototypes) + +# Can't use Carp because it might cause C to accidentally succeed +# even though the module being used forgot to use Carp. Yes, this +# actually happened. +sub _carp { + my( $file, $line ) = ( caller(1) )[ 1, 2 ]; + return warn @_, " at $file line $line\n"; +} + +our $VERSION = '1.302175'; + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + done_testing + can_ok isa_ok new_ok + diag note explain + subtest + BAIL_OUT +); + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => 23; + # or + use Test::More skip_all => $reason; + # or + use Test::More; # see done_testing() + + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($got eq $expected, $test_name); + + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); + + # Rather than print STDERR "# here's what went wrong\n" + diag("here's what went wrong"); + + like ($got, qr/expected/, $test_name); + unlike($got, qr/expected/, $test_name); + + cmp_ok($got, '==', $expected, $test_name); + + is_deeply($got_complex_structure, $expected_complex_structure, $test_name); + + SKIP: { + skip $why, $how_many unless $have_some_feature; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + TODO: { + local $TODO = $why; + + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + }; + + can_ok($module, @methods); + isa_ok($object, $class); + + pass($test_name); + fail($test_name); + + BAIL_OUT($why); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + +=head1 DESCRIPTION + +B If you're just getting started writing tests, have a look at +L first. + +This is a drop in replacement for Test::Simple which you can switch to once you +get the hang of basic testing. + +The purpose of this module is to provide a wide range of testing +utilities. Various ways to say "ok" with better diagnostics, +facilities to skip tests, test future features and compare complicated +data structures. While you can do almost anything with a simple +C function, it doesn't provide good diagnostic output. + + +=head2 I love it when a plan comes together + +Before anything else, you need a testing plan. This basically declares +how many tests your script is going to run to protect against premature +failure. + +The preferred way to do this is to declare a plan when you C. + + use Test::More tests => 23; + +There are cases when you will not know beforehand how many tests your +script is going to run. In this case, you can declare your tests at +the end. + + use Test::More; + + ... run your tests ... + + done_testing( $number_of_tests_run ); + +B C should never be called in an C block. + +Sometimes you really don't know how many tests were run, or it's too +difficult to calculate. In which case you can leave off +$number_of_tests_run. + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More skip_all => $skip_reason; + +Your script will declare a skip with the reason why you skipped and +exit immediately with a zero (success). See L for +details. + +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the C function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevant on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my $tb = Test::More->builder; + + return $tb->plan(@_); +} + +# This implements "use Test::More 'no_diag'" but the behavior is +# deprecated. +sub import_extra { + my $class = shift; + my $list = shift; + + my @other = (); + my $idx = 0; + my $import; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'no_diag' ) { + $class->builder->no_diag(1); + } + elsif( defined $item and $item eq 'import' ) { + if ($import) { + push @$import, @{$list->[ ++$idx ]}; + } + else { + $import = $list->[ ++$idx ]; + push @other, $item, $import; + } + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { + my $to = $class->builder->exported_to; + no strict 'refs'; + *{"$to\::TODO"} = \our $TODO; + if ($import) { + @$import = grep $_ ne '$TODO', @$import; + } + else { + push @$list, import => [grep $_ ne '$TODO', @EXPORT]; + } + } + + return; +} + +=over 4 + +=item B + + done_testing(); + done_testing($number_of_tests); + +If you don't know how many tests you're going to run, you can issue +the plan when you're done running tests. + +$number_of_tests is the same as C, it's the number of tests you +expected to run. You can omit this, in which case the number of tests +you ran doesn't matter, just the fact that your tests ran to +conclusion. + +This is safer than and replaces the "no_plan" plan. + +B You must never put C inside an C block. +The plan is there to ensure your test does not exit before testing has +completed. If you use an END block you completely bypass this protection. + +=back + +=cut + +sub done_testing { + my $tb = Test::More->builder; + $tb->done_testing(@_); +} + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, it's often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. It's optional, but highly +suggested that you use it. + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B + + ok($got eq $expected, $test_name); + +This simply evaluates any expression (C<$got eq $expected> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep(!defined $_, @items), 'all items defined' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B strongly encourage its use. + +Should an C fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 'sufficient mucus' + # in foo.t at line 42. + +This is the same as L's C routine. + +=cut + +sub ok ($;$) { + my( $test, $name ) = @_; + my $tb = Test::More->builder; + + return $tb->ok( $test, $name ); +} + +=item B + +=item B + + is ( $got, $expected, $test_name ); + isnt( $got, $expected, $test_name ); + +Similar to C, C and C compare their two arguments +with C and C respectively and use the result of that to +determine if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +C will only ever match C. So you can test a value +against C like this: + + is($not_defined, undef, "undefined as expected"); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. C +cannot know what you are testing for (beyond the name), but C and +C know what the test was and why it failed. For example this +test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test 'Is foo the same as bar?' + # in foo.t at line 139. + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use C and C over C where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! + is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); + +This does not check if C is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use C. + + ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); + +A simple call to C usually does not provide a strong test but there +are cases when you cannot say much more about a value than that it is +different from some other value: + + new_ok $obj, "Foo"; + + my $clone = $obj->clone; + isa_ok $obj, "Foo", "Foo->clone"; + + isnt $obj, $clone, "clone() produces a different object"; + +For those grammatical pedants out there, there's an C +function which is an alias of C. + +=cut + +sub is ($$;$) { + my $tb = Test::More->builder; + + return $tb->is_eq(@_); +} + +sub isnt ($$;$) { + my $tb = Test::More->builder; + + return $tb->isnt_eq(@_); +} + +*isn't = \&isnt; +# ' to unconfuse syntax higlighters + +=item B + + like( $got, qr/expected/, $test_name ); + +Similar to C, C matches $got against the regex C. + +So this: + + like($got, qr/expected/, 'this is like that'); + +is similar to: + + ok( $got =~ m/expected/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (i.e. C) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $got, '/expected/', 'this is like that' ); + +Regex options may be placed on the end (C<'/expected/i'>). + +Its advantages over C are similar to that of C and C. Better +diagnostics on failure. + +=cut + +sub like ($$;$) { + my $tb = Test::More->builder; + + return $tb->like(@_); +} + +=item B + + unlike( $got, qr/expected/, $test_name ); + +Works exactly as C, only it checks if $got B match the +given pattern. + +=cut + +sub unlike ($$;$) { + my $tb = Test::More->builder; + + return $tb->unlike(@_); +} + +=item B + + cmp_ok( $got, $op, $expected, $test_name ); + +Halfway between C and C lies C. This allows you +to compare two arguments using any binary perl operator. The test +passes if the comparison is true and fails otherwise. + + # ok( $got eq $expected ); + cmp_ok( $got, 'eq', $expected, 'this eq that' ); + + # ok( $got == $expected ); + cmp_ok( $got, '==', $expected, 'this == that' ); + + # ok( $got && $expected ); + cmp_ok( $got, '&&', $expected, 'this && that' ); + ...etc... + +Its advantage over C is when the test fails you'll know what $got +and $expected were: + + not ok 1 + # Failed test in foo.t at line 12. + # '23' + # && + # undef + +It's also useful in those cases where you are comparing numbers and +C's use of C will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +It's especially useful when comparing greater-than or smaller-than +relation between values: + + cmp_ok( $some_value, '<=', $upper_limit ); + + +=cut + +sub cmp_ok($$$;$) { + my $tb = Test::More->builder; + + return $tb->cmp_ok(@_); +} + +=item B + + can_ok($module, @methods); + can_ok($object, @methods); + +Checks to make sure the $module or $object can do these @methods +(works with functions, too). + + can_ok('Foo', qw(this that whatever)); + +is almost exactly like saying: + + ok( Foo->can('this') && + Foo->can('that') && + Foo->can('whatever') + ); + +only without all the typing and with a better interface. Handy for +quickly testing an interface. + +No matter how many @methods you check, a single C call counts +as one test. If you desire otherwise, use: + + foreach my $meth (@methods) { + can_ok('Foo', $meth); + } + +=cut + +sub can_ok ($@) { + my( $proto, @methods ) = @_; + my $class = ref $proto || $proto; + my $tb = Test::More->builder; + + unless($class) { + my $ok = $tb->ok( 0, "->can(...)" ); + $tb->diag(' can_ok() called with empty class or reference'); + return $ok; + } + + unless(@methods) { + my $ok = $tb->ok( 0, "$class->can(...)" ); + $tb->diag(' can_ok() called with no methods'); + return $ok; + } + + my @nok = (); + foreach my $method (@methods) { + $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; + } + + my $name = (@methods == 1) ? "$class->can('$methods[0]')" : + "$class->can(...)" ; + + my $ok = $tb->ok( !@nok, $name ); + + $tb->diag( map " $class->can('$_') failed\n", @nok ); + + return $ok; +} + +=item B + + isa_ok($object, $class, $object_name); + isa_ok($subclass, $class, $object_name); + isa_ok($ref, $type, $ref_name); + +Checks to see if the given C<< $object->isa($class) >>. Also checks to make +sure the object was defined in the first place. Handy for this sort +of thing: + + my $obj = Some::Module->new; + isa_ok( $obj, 'Some::Module' ); + +where you'd otherwise have to write + + my $obj = Some::Module->new; + ok( defined $obj && $obj->isa('Some::Module') ); + +to safeguard against your test script blowing up. + +You can also test a class, to make sure that it has the right ancestor: + + isa_ok( 'Vole', 'Rodent' ); + +It works on references, too: + + isa_ok( $array_ref, 'ARRAY' ); + +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + +=cut + +sub isa_ok ($$;$) { + my( $thing, $class, $thing_name ) = @_; + my $tb = Test::More->builder; + + my $whatami; + if( !defined $thing ) { + $whatami = 'undef'; + } + elsif( ref $thing ) { + $whatami = 'reference'; + + local($@,$!); + require Scalar::Util; + if( Scalar::Util::blessed($thing) ) { + $whatami = 'object'; + } + } + else { + $whatami = 'class'; + } + + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); + + if($error) { + die <isa on your $whatami and got some weird error. +Here's the error. +$error +WHOA + } + + # Special case for isa_ok( [], "ARRAY" ) and like + if( $whatami eq 'reference' ) { + $rslt = UNIVERSAL::isa($thing, $class); + } + + my($diag, $name); + if( defined $thing_name ) { + $name = "'$thing_name' isa '$class'"; + $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; + } + elsif( $whatami eq 'object' ) { + my $my_class = ref $thing; + $thing_name = qq[An object of class '$my_class']; + $name = "$thing_name isa '$class'"; + $diag = "The object of class '$my_class' isn't a '$class'"; + } + elsif( $whatami eq 'reference' ) { + my $type = ref $thing; + $thing_name = qq[A reference of type '$type']; + $name = "$thing_name isa '$class'"; + $diag = "The reference of type '$type' isn't a '$class'"; + } + elsif( $whatami eq 'undef' ) { + $thing_name = 'undef'; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't defined"; + } + elsif( $whatami eq 'class' ) { + $thing_name = qq[The class (or class-like) '$thing']; + $name = "$thing_name isa '$class'"; + $diag = "$thing_name isn't a '$class'"; + } + else { + die; + } + + my $ok; + if($rslt) { + $ok = $tb->ok( 1, $name ); + } + else { + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); + } + + return $ok; +} + +=item B + + my $obj = new_ok( $class ); + my $obj = new_ok( $class => \@args ); + my $obj = new_ok( $class => \@args, $object_name ); + +A convenience function which combines creating an object and calling +C on that object. + +It is basically equivalent to: + + my $obj = $class->new(@args); + isa_ok $obj, $class, $object_name; + +If @args is not given, an empty list will be used. + +This function only works on C and it assumes C will return +just a single object which isa C<$class>. + +=cut + +sub new_ok { + my $tb = Test::More->builder; + $tb->croak("new_ok() must be given at least a class") unless @_; + + my( $class, $args, $object_name ) = @_; + + $args ||= []; + + my $obj; + my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); + if($success) { + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok $obj, $class, $object_name; + } + else { + $class = 'undef' if !defined $class; + $tb->ok( 0, "$class->new() died" ); + $tb->diag(" Error was: $error"); + } + + return $obj; +} + +=item B + + subtest $name => \&code, @args; + +C runs the &code as its own little test with its own plan and +its own result. The main test counts this as a single test using the +result of the whole subtest to determine if its ok or not ok. + +For example... + + use Test::More tests => 3; + + pass("First test"); + + subtest 'An example subtest' => sub { + plan tests => 2; + + pass("This is a subtest"); + pass("So is this"); + }; + + pass("Third test"); + +This would produce. + + 1..3 + ok 1 - First test + # Subtest: An example subtest + 1..2 + ok 1 - This is a subtest + ok 2 - So is this + ok 2 - An example subtest + ok 3 - Third test + +A subtest may call C. No tests will be run, but the subtest is +considered a skip. + + subtest 'skippy' => sub { + plan skip_all => 'cuz I said so'; + pass('this test will never be run'); + }; + +Returns true if the subtest passed, false otherwise. + +Due to how subtests work, you may omit a plan if you desire. This adds an +implicit C to the end of your subtest. The following two +subtests are equivalent: + + subtest 'subtest with implicit done_testing()', sub { + ok 1, 'subtests with an implicit done testing should work'; + ok 1, '... and support more than one test'; + ok 1, '... no matter how many tests are run'; + }; + + subtest 'subtest with explicit done_testing()', sub { + ok 1, 'subtests with an explicit done testing should work'; + ok 1, '... and support more than one test'; + ok 1, '... no matter how many tests are run'; + done_testing(); + }; + +Extra arguments given to C are passed to the callback. For example: + + sub my_subtest { + my $range = shift; + ... + } + + for my $range (1, 10, 100, 1000) { + subtest "testing range $range", \&my_subtest, $range; + } + +=cut + +sub subtest { + my $tb = Test::More->builder; + return $tb->subtest(@_); +} + +=item B + +=item B + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an C. In this case, you can simply use C (to +declare the test ok) or fail (for not ok). They are synonyms for +C and C. + +Use these very, very, very sparingly. + +=cut + +sub pass (;$) { + my $tb = Test::More->builder; + + return $tb->ok( 1, @_ ); +} + +sub fail (;$) { + my $tb = Test::More->builder; + + return $tb->ok( 0, @_ ); +} + +=back + + +=head2 Module tests + +Sometimes you want to test if a module, or a list of modules, can +successfully load. For example, you'll often want a first test which +simply loads all the modules in the distribution to make sure they +work before going on to do more complicated testing. + +For such purposes we have C and C. + +=over 4 + +=item B + + require_ok($module); + require_ok($file); + +Tries to C the given $module or $file. If it loads +successfully, the test will pass. Otherwise it fails and displays the +load error. + +C will guess whether the input is a module name or a +filename. + +No exception will be thrown if the load fails. + + # require Some::Module + require_ok "Some::Module"; + + # require "Some/File.pl"; + require_ok "Some/File.pl"; + + # stop testing if any of your modules will not load + for my $module (@module) { + require_ok $module or BAIL_OUT "Can't load $module"; + } + +=cut + +sub require_ok ($) { + my($module) = shift; + my $tb = Test::More->builder; + + my $pack = caller; + + # Try to determine if we've been given a module name or file. + # Module names must be barewords, files not. + $module = qq['$module'] unless _is_module_name($module); + + my $code = <ok( $eval_result, "require $module;" ); + + unless($ok) { + chomp $eval_error; + $tb->diag(< + + BEGIN { use_ok($module); } + BEGIN { use_ok($module, @imports); } + +Like C, but it will C the $module in question and +only loads modules, not files. + +If you just want to test a module can be loaded, use C. + +If you just want to load a module in a test, we recommend simply using +C directly. It will cause the test to stop. + +It's recommended that you run C inside a BEGIN block so its +functions are exported at compile-time and prototypes are properly +honored. + +If @imports are given, they are passed through to the use. So this: + + BEGIN { use_ok('Some::Module', qw(foo bar)) } + +is like doing this: + + use Some::Module qw(foo bar); + +Version numbers can be checked like so: + + # Just like "use Some::Module 1.02" + BEGIN { use_ok('Some::Module', 1.02) } + +Don't try to do this: + + BEGIN { + use_ok('Some::Module'); + + ...some code that depends on the use... + ...happening at compile time... + } + +because the notion of "compile-time" is relative. Instead, you want: + + BEGIN { use_ok('Some::Module') } + BEGIN { ...some code that depends on the use... } + +If you want the equivalent of C, use a module but not +import anything, use C. + + BEGIN { require_ok "Foo" } + +=cut + +sub use_ok ($;@) { + my( $module, @imports ) = @_; + @imports = () unless @imports; + my $tb = Test::More->builder; + + my %caller; + @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); + + my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; + $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line + + my $code; + if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { + # probably a version check. Perl needs to see the bare number + # for it to work with non-Exporter based modules. + $code = <ok( $eval_result, "use $module;" ); + + unless($ok) { + chomp $eval_error; + $@ =~ s{^BEGIN failed--compilation aborted at .*$} + {BEGIN failed--compilation aborted at $filename line $line.}m; + $tb->diag(< I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B + + is_deeply( $got, $expected, $test_name ); + +Similar to C, except that if $got and $expected are references, it +does a deep comparison walking each data structure to see if they are +equivalent. If the two structures are different, it will display the +place where they start differing. + +C compares the dereferenced values of references, the +references themselves (except for their type) are ignored. This means +aspects such as blessing and ties are not considered "different". + +C currently has very limited handling of function reference +and globs. It merely checks if they have the same referent. This may +improve in the future. + +L and L provide more in-depth functionality +along these lines. + +B is_deeply() has limitations when it comes to comparing strings and +refs: + + my $path = path('.'); + my $hash = {}; + is_deeply( $path, "$path" ); # ok + is_deeply( $hash, "$hash" ); # fail + +This happens because is_deeply will unoverload all arguments unconditionally. +It is probably best not to use is_deeply with overloading. For legacy reasons +this is not likely to ever be fixed. If you would like a much better tool for +this you should see L Specifically L has +an C function that works like C with many improvements. + +=cut + +our( @Data_Stack, %Refs_Seen ); +my $DNE = bless [], 'Does::Not::Exist'; + +sub _dne { + return ref $_[0] eq ref $DNE; +} + +## no critic (Subroutines::RequireArgUnpacking) +sub is_deeply { + my $tb = Test::More->builder; + + unless( @_ == 2 or @_ == 3 ) { + my $msg = <<'WARNING'; +is_deeply() takes two or three args, you gave %d. +This usually means you passed an array or hash instead +of a reference to it +WARNING + chop $msg; # clip off newline so carp() will put in line/file + + _carp sprintf $msg, scalar @_; + + return $tb->ok(0); + } + + my( $got, $expected, $name ) = @_; + + $tb->_unoverload_str( \$expected, \$got ); + + my $ok; + if( !ref $got and !ref $expected ) { # neither is a reference + $ok = $tb->is_eq( $got, $expected, $name ); + } + elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); + } + else { # both references + local @Data_Stack = (); + if( _deep_check( $got, $expected ) ) { + $ok = $tb->ok( 1, $name ); + } + else { + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack(@Data_Stack) ); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; + my @vars = (); + ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; + ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx ( 0 .. $#vals ) { + my $val = $vals[$idx]; + $vals[$idx] + = !defined $val ? 'undef' + : _dne($val) ? "Does not exist" + : ref $val ? "$val" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + $out =~ s/^/ /msg; + return $out; +} + +sub _type { + my $thing = shift; + + return '' if !ref $thing; + + for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { + return $type if UNIVERSAL::isa( $thing, $type ); + } + + return ''; +} + +=back + + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C. + +=over 4 + +=item B + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C @diagnostic_message is simply concatenated +together. + +Returns false, so as to preserve failure. + +Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test 'There's a foo user' + # in foo.t at line 52. + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C with the mnemonic C. + +B The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it won't +interfere with the test. + +=item B + + note(@diagnostic_message); + +Like C, except the message will not be seen when the test is run +in a harness. It will only be visible in the verbose TAP stream. + +Handy for putting in notes which might be useful for debugging, but +don't indicate a problem. + + note("Tempfile is $tempfile"); + +=cut + +sub diag { + return Test::More->builder->diag(@_); +} + +sub note { + return Test::More->builder->note(@_); +} + +=item B + + my @dump = explain @diagnostic_message; + +Will dump the contents of any references in a human readable format. +Usually you want to pass this into C or C. + +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + note explain \%args; + Some::Class->method(%args); + +=cut + +sub explain { + return Test::More->builder->explain(@_); +} + +=back + + +=head2 Conditional tests + +Sometimes running a test under certain conditions will cause the +test script to die. A certain function or method isn't implemented +(such as C on MacOS), some resource isn't available (like a +net connection) or a module isn't available. In these cases it's +necessary to skip tests, or declare that they are supposed to fail +but will work in the future (a todo test). + +For more details on the mechanics of skip and todo tests see +L. + +The way Test::More handles this is with a named block. Basically, a +block of tests which can be skipped over or made todo. It's best if I +just show you... + +=over 4 + +=item B + + SKIP: { + skip $why, $how_many if $condition; + + ...normal testing code goes here... + } + +This declares a block of tests that might be skipped, $how_many tests +there are, $why and under what $condition to skip them. An example is +the easiest way to illustrate: + + SKIP: { + eval { require HTML::Lint }; + + skip "HTML::Lint not installed", 2 if $@; + + my $lint = new HTML::Lint; + isa_ok( $lint, "HTML::Lint" ); + + $lint->parse( $html ); + is( $lint->errors, 0, "No errors found in HTML" ); + } + +If the user does not have HTML::Lint installed, the whole block of +code I. Test::More will output special ok's +which Test::Harness interprets as skipped, but passing, tests. + +It's important that $how_many accurately reflects the number of tests +in the SKIP block so the # of tests run will match up with your plan. +If your plan is C $how_many is optional and will default to 1. + +It's perfectly safe to nest SKIP blocks. Each SKIP block must have +the label C, or Test::More can't work its magic. + +You don't skip tests which are failing because there's a bug in your +program, or for which you don't yet have code written. For that you +use TODO. Read on. + +=cut + +## no critic (Subroutines::RequireFinalReturn) +sub skip { + my( $why, $how_many ) = @_; + my $tb = Test::More->builder; + + # If the plan is set, and is static, then skip needs a count. If the plan + # is 'no_plan' we are fine. As well if plan is undefined then we are + # waiting for done_testing. + unless (defined $how_many) { + my $plan = $tb->has_plan; + _carp "skip() needs to know \$how_many tests are in the block" + if $plan && $plan =~ m/^\d+$/; + $how_many = 1; + } + + if( defined $how_many and $how_many =~ /\D/ ) { + _carp + "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; + $how_many = 1; + } + + for( 1 .. $how_many ) { + $tb->skip($why); + } + + no warnings 'exiting'; + last SKIP; +} + +=item B + + TODO: { + local $TODO = $why if $condition; + + ...normal testing code goes here... + } + +Declares a block of tests you expect to fail and $why. Perhaps it's +because you haven't fixed a bug or haven't finished a new feature: + + TODO: { + local $TODO = "URI::Geller not finished"; + + my $card = "Eight of clubs"; + is( URI::Geller->your_card, $card, 'Is THIS your card?' ); + + my $spoon; + URI::Geller->bend_spoon; + is( $spoon, 'bent', "Spoon bending, that's original" ); + } + +With a todo block, the tests inside are expected to fail. Test::More +will run the tests normally, but print out special flags indicating +they are "todo". L will interpret failures as being ok. +Should anything succeed, it will report it as an unexpected success. +You then know the thing you had todo is done and can remove the +TODO flag. + +The nice part about todo tests, as opposed to simply commenting out a +block of tests, is that it is like having a programmatic todo list. You know +how much work is left to be done, you're aware of what bugs there are, +and you'll know immediately when they're fixed. + +Once a todo test starts succeeding, simply move it outside the block. +When the block is empty, delete it. + + +=item B + + TODO: { + todo_skip $why, $how_many if $condition; + + ...normal testing code... + } + +With todo tests, it's best to have the tests actually run. That way +you'll know when they start passing. Sometimes this isn't possible. +Often a failing test will cause the whole program to die or hang, even +inside an C with and using C. In these extreme +cases you have no choice but to skip over the broken tests entirely. + +The syntax and behavior is similar to a C except the +tests will be marked as failing but todo. L will +interpret them as passing. + +=cut + +sub todo_skip { + my( $why, $how_many ) = @_; + my $tb = Test::More->builder; + + unless( defined $how_many ) { + # $how_many can only be avoided when no_plan is in use. + _carp "todo_skip() needs to know \$how_many tests are in the block" + unless $tb->has_plan eq 'no_plan'; + $how_many = 1; + } + + for( 1 .. $how_many ) { + $tb->todo_skip($why); + } + + no warnings 'exiting'; + last TODO; +} + +=item When do I use SKIP vs. TODO? + +B, use SKIP. +This includes optional modules that aren't installed, running under +an OS that doesn't have some feature (like C or symlinks), or maybe +you need an Internet connection and one isn't available. + +B, use TODO. This +is for any code you haven't written yet, or bugs you have yet to fix, +but want to put tests in your testing script (always a good idea). + + +=back + + +=head2 Test control + +=over 4 + +=item B + + BAIL_OUT($reason); + +Indicates to the harness that things are going so badly all testing +should terminate. This includes the running of any additional test scripts. + +This is typically used when testing cannot continue such as a critical +module failing to compile or a necessary external utility not being +available such as a database connection failing. + +The test will exit with 255. + +For even better control look at L. + +=cut + +sub BAIL_OUT { + my $reason = shift; + my $tb = Test::More->builder; + + $tb->BAIL_OUT($reason); +} + +=back + + +=head2 Discouraged comparison functions + +The use of the following functions is discouraged as they are not +actually testing functions and produce no diagnostics to help figure +out what went wrong. They were written before C existed +because I couldn't figure out how to display a useful diff of two +arbitrary data structures. + +These functions are usually used inside an C. + + ok( eq_array(\@got, \@expected) ); + +C can do that better and with diagnostics. + + is_deeply( \@got, \@expected ); + +They may be deprecated in future versions. + +=over 4 + +=item B + + my $is_eq = eq_array(\@got, \@expected); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +sub eq_array { + local @Data_Stack = (); + _deep_check(@_); +} + +sub _eq_array { + my( $a1, $a2 ) = @_; + + if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { + warn "eq_array passed a non-array ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + my $ok = 1; + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for( 0 .. $max ) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + next if _equal_nonrefs($e1, $e2); + + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +sub _equal_nonrefs { + my( $e1, $e2 ) = @_; + + return if ref $e1 or ref $e2; + + if ( defined $e1 ) { + return 1 if defined $e2 and $e1 eq $e2; + } + else { + return 1 if !defined $e2; + } + + return; +} + +sub _deep_check { + my( $e1, $e2 ) = @_; + my $tb = Test::More->builder; + + my $ok = 0; + + # Effectively turn %Refs_Seen into a stack. This avoids picking up + # the same referenced used twice (such as [\$a, \$a]) to be considered + # circular. + local %Refs_Seen = %Refs_Seen; + + { + $tb->_unoverload_str( \$e1, \$e2 ); + + # Either they're both references or both not. + my $same_ref = !( !ref $e1 xor !ref $e2 ); + my $not_ref = ( !ref $e1 and !ref $e2 ); + + if( defined $e1 xor defined $e2 ) { + $ok = 0; + } + elsif( !defined $e1 and !defined $e2 ) { + # Shortcut if they're both undefined. + $ok = 1; + } + elsif( _dne($e1) xor _dne($e2) ) { + $ok = 0; + } + elsif( $same_ref and( $e1 eq $e2 ) ) { + $ok = 1; + } + elsif($not_ref) { + push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; + $ok = 0; + } + else { + if( $Refs_Seen{$e1} ) { + return $Refs_Seen{$e1} eq $e2; + } + else { + $Refs_Seen{$e1} = "$e2"; + } + + my $type = _type($e1); + $type = 'DIFFERENT' unless _type($e2) eq $type; + + if( $type eq 'DIFFERENT' ) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = 0; + } + elsif( $type eq 'ARRAY' ) { + $ok = _eq_array( $e1, $e2 ); + } + elsif( $type eq 'HASH' ) { + $ok = _eq_hash( $e1, $e2 ); + } + elsif( $type eq 'REF' ) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); + pop @Data_Stack if $ok; + } + elsif( $type eq 'SCALAR' ) { + push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); + pop @Data_Stack if $ok; + } + elsif($type) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = 0; + } + else { + _whoa( 1, "No type in _deep_check" ); + } + } + } + + return $ok; +} + +sub _whoa { + my( $check, $desc ) = @_; + if($check) { + die <<"WHOA"; +WHOA! $desc +This should never happen! Please contact the author immediately! +WHOA + } +} + +=item B + + my $is_eq = eq_hash(\%got, \%expected); + +Determines if the two hashes contain the same keys and values. This +is a deep check. + +=cut + +sub eq_hash { + local @Data_Stack = (); + return _deep_check(@_); +} + +sub _eq_hash { + my( $a1, $a2 ) = @_; + + if( grep _type($_) ne 'HASH', $a1, $a2 ) { + warn "eq_hash passed a non-hash ref"; + return 0; + } + + return 1 if $a1 eq $a2; + + my $ok = 1; + my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; + foreach my $k ( keys %$bigger ) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + + next if _equal_nonrefs($e1, $e2); + + push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); + pop @Data_Stack if $ok; + + last unless $ok; + } + + return $ok; +} + +=item B + + my $is_eq = eq_set(\@got, \@expected); + +Similar to C, except the order of the elements is B +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + + ok( eq_set(\@got, \@expected) ); + +Is better written: + + is_deeply( [sort @got], [sort @expected] ); + +B By historical accident, this is not a true set comparison. +While the order of elements does not matter, duplicate elements do. + +B C does not know how to deal with references at the top +level. The following is an example of a comparison which might not work: + + eq_set([\1, \2], [\2, \1]); + +L contains much better set comparison functions. + +=cut + +sub eq_set { + my( $a1, $a2 ) = @_; + return 0 unless @$a1 == @$a2; + + no warnings 'uninitialized'; + + # It really doesn't matter how we sort them, as long as both arrays are + # sorted with the same algorithm. + # + # Ensure that references are not accidentally treated the same as a + # string containing the reference. + # + # Have to inline the sort routine due to a threading/sort bug. + # See [rt.cpan.org 6782] + # + # I don't know how references would be sorted so we just don't sort + # them. This means eq_set doesn't really work with refs. + return eq_array( + [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], + [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], + ); +} + +=back + + +=head2 Extending and Embedding Test::More + +Sometimes the Test::More interface isn't quite enough. Fortunately, +Test::More is built on top of L which provides a single, +unified backend for any test library to use. This means two test +libraries which both use B be used together in the +same program>. + +If you simply want to do a little tweaking of how the tests behave, +you can access the underlying L object like so: + +=over 4 + +=item B + + my $test_builder = Test::More->builder; + +Returns the L object underlying Test::More for you to play +with. + + +=back + + +=head1 EXIT CODES + +If all your tests passed, L will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run L +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +B This behavior may go away in future versions. + + +=head1 COMPATIBILITY + +Test::More works with Perls as old as 5.8.1. + +Thread support is not very reliable before 5.10.1, but that's +because threads are not very reliable before 5.10.1. + +Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. + +Key feature milestones include: + +=over 4 + +=item subtests + +Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. + +=item C + +This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. + +=item C + +Although C was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. + +=item C C and C + +These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. + +=back + +There is a full version history in the Changes file, and the Test::More versions included as core can be found using L: + + $ corelist -a Test::More + + +=head1 CAVEATS and NOTES + +=over 4 + +=item utf8 / "Wide character in print" + +If you use utf8 or other non-ASCII characters with Test::More you +might get a "Wide character in print" warning. Using +C<< binmode STDOUT, ":utf8" >> will not fix it. +L (which powers +Test::More) duplicates STDOUT and STDERR. So any changes to them, +including changing their output disciplines, will not be seen by +Test::More. + +One work around is to apply encodings to STDOUT and STDERR as early +as possible and before Test::More (or any other Test module) loads. + + use open ':std', ':encoding(utf8)'; + use Test::More; + +A more direct work around is to change the filehandles used by +L. + + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; + + +=item Overloaded objects + +String overloaded objects are compared B (or in C's +case, strings or numbers as appropriate to the comparison op). This +prevents Test::More from piercing an object's interface allowing +better blackbox testing. So if a function starts returning overloaded +objects instead of bare strings your tests won't notice the +difference. This is good. + +However, it does mean that functions like C cannot be used to +test the internals of string overloaded objects. In this case I would +suggest L which contains more flexible testing functions for +complex data structures. + + +=item Threads + +Test::More will only be aware of threads if C has been done +I Test::More is loaded. This is ok: + + use threads; + use Test::More; + +This may cause problems: + + use Test::More + use threads; + +5.8.1 and above are supported. Anything below that has too many bugs. + +=back + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's L +module. I was largely unaware of its existence when I'd first +written my own C routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +=head2 + +=head2 ALTERNATIVES + +L is the most recent and modern set of tools for testing. + +L if all this confuses you and you just want to write +some tests. You can upgrade to Test::More later (it's forward +compatible). + +L tests written with Test.pm, the original testing +module, do not play well with other testing libraries. Test::Legacy +emulates the Test.pm interface and does play well with others. + +=head2 ADDITIONAL LIBRARIES + +L for more ways to test complex data structures. +And it plays well with Test::More. + +L is like xUnit but more perlish. + +L gives you more powerful complex data structure testing. + +L shows the idea of embedded testing. + +L The ultimate mocking library. Easily spawn objects defined on +the fly. Can also override, block, or reimplement packages as needed. + +L Quickly define fixture data for unit tests. + +=head2 OTHER COMPONENTS + +L is the test runner and output interpreter for Perl. +It's the thing that powers C and where the C utility +comes from. + +=head2 BUNDLES + +L Most commonly needed test functions and features. + +=head1 AUTHORS + +Michael G Schwern Eschwern@pobox.comE with much inspiration +from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and +the perl-qa gang. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + + +=head1 BUGS + +See F to report and view bugs. + + +=head1 SOURCE + +The source code repository for Test::More can be found at +F. + + +=head1 COPYRIGHT + +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Simple.pm ddclient-3.10.0/t/lib/Test/Simple.pm --- ddclient-3.9.1/t/lib/Test/Simple.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Simple.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,220 @@ +package Test::Simple; + +use 5.006; + +use strict; + +our $VERSION = '1.302175'; + +use Test::Builder::Module; +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); + +my $CLASS = __PACKAGE__; + +=head1 NAME + +Test::Simple - Basic utilities for writing tests. + +=head1 SYNOPSIS + + use Test::Simple tests => 1; + + ok( $foo eq $bar, 'foo is bar' ); + + +=head1 DESCRIPTION + +** If you are unfamiliar with testing B first!> ** + +This is an extremely simple, extremely basic module for writing tests +suitable for CPAN modules and other pursuits. If you wish to do more +complicated testing, use the Test::More module (a drop-in replacement +for this one). + +The basic unit of Perl testing is the ok. For each thing you want to +test your program will print out an "ok" or "not ok" to indicate pass +or fail. You do this with the C function (see below). + +The only other constraint is you must pre-declare how many tests you +plan to run. This is in case something goes horribly wrong during the +test and your test program aborts, or skips a test or whatever. You +do this like so: + + use Test::Simple tests => 23; + +You must have a plan. + + +=over 4 + +=item B + + ok( $foo eq $bar, $name ); + ok( $foo eq $bar ); + +C is given an expression (in this case C<$foo eq $bar>). If it's +true, the test passed. If it's false, it didn't. That's about it. + +C prints out either "ok" or "not ok" along with a test number (it +keeps track of that for you). + + # This produces "ok 1 - Hell not yet frozen over" (or not ok) + ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); + +If you provide a $name, that will be printed along with the "ok/not +ok" to make it easier to find your test when if fails (just search for +the name). It also makes it easier for the next guy to understand +what your test is for. It's highly recommended you use test names. + +All tests are run in scalar context. So this: + + ok( @stuff, 'I have some stuff' ); + +will do what you mean (fail if stuff is empty) + +=cut + +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + return $CLASS->builder->ok(@_); +} + +=back + +Test::Simple will start by printing number of tests run in the form +"1..M" (so "1..5" means you're going to run 5 tests). This strange +format lets L know how many tests you plan on running in +case something goes horribly wrong. + +If all your tests passed, Test::Simple will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Simple +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + +This module is by no means trying to be a complete testing system. +It's just to get you started. Once you're off the ground its +recommended you look at L. + + +=head1 EXAMPLE + +Here's an example of a simple .t file for the fictional Film module. + + use Test::Simple tests => 5; + + use Film; # What you're testing. + + my $btaste = Film->new({ Title => 'Bad Taste', + Director => 'Peter Jackson', + Rating => 'R', + NumExplodingSheep => 1 + }); + ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' ); + + ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); + ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); + ok( $btaste->Rating eq 'R', 'Rating() get' ); + ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); + +It will produce output like this: + + 1..5 + ok 1 - new() works + ok 2 - Title() get + ok 3 - Director() get + not ok 4 - Rating() get + # Failed test 'Rating() get' + # in t/film.t at line 14. + ok 5 - NumExplodingSheep() get + # Looks like you failed 1 tests of 5 + +Indicating the Film::Rating() method is broken. + + +=head1 CAVEATS + +Test::Simple will only report a maximum of 254 failures in its exit +code. If this is a problem, you probably have a huge test script. +Split it into multiple files. (Otherwise blame the Unix folks for +using an unsigned short integer as the exit status). + +Because VMS's exit codes are much, much different than the rest of the +universe, and perl does horrible mangling to them that gets in my way, +it works like this on VMS. + + 0 SS$_NORMAL all tests successful + 4 SS$_ABORT something went wrong + +Unfortunately, I can't differentiate any further. + + +=head1 NOTES + +Test::Simple is B tested all the way back to perl 5.6.0. + +Test::Simple is thread-safe in perl 5.8.1 and up. + +=head1 HISTORY + +This module was conceived while talking with Tony Bowden in his +kitchen one night about the problems I was having writing some really +complicated feature into the new Testing module. He observed that the +main problem is not dealing with these edge cases but that people hate +to write tests B. What was needed was a dead simple module +that took all the hard work out of testing and was really, really easy +to learn. Paul Johnson simultaneously had this idea (unfortunately, +he wasn't in Tony's kitchen). This is it. + + +=head1 SEE ALSO + +=over 4 + +=item L + +More testing functions! Once you outgrow Test::Simple, look at +L. Test::Simple is 100% forward compatible with L +(i.e. you can just use L instead of Test::Simple in your +programs and things will still work). + +=back + +Look in L's SEE ALSO for more testing modules. + + +=head1 AUTHORS + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +Eschwern@pobox.comE, wardrobe by Calvin Klein. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Tester/Capture.pm ddclient-3.10.0/t/lib/Test/Tester/Capture.pm --- ddclient-3.9.1/t/lib/Test/Tester/Capture.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Tester/Capture.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,241 @@ +use strict; + +package Test::Tester::Capture; + +our $VERSION = '1.302175'; + + +use Test::Builder; + +use vars qw( @ISA ); +@ISA = qw( Test::Builder ); + +# Make Test::Tester::Capture thread-safe for ithreads. +BEGIN { + use Config; + *share = sub { 0 }; + *lock = sub { 0 }; +} + +my $Curr_Test = 0; share($Curr_Test); +my @Test_Results = (); share(@Test_Results); +my $Prem_Diag = {diag => ""}; share($Curr_Test); + +sub new +{ + # Test::Tester::Capgture::new used to just return __PACKAGE__ + # because Test::Builder::new enforced its singleton nature by + # return __PACKAGE__. That has since changed, Test::Builder::new now + # returns a blessed has and around version 0.78, Test::Builder::todo + # started wanting to modify $self. To cope with this, we now return + # a blessed hash. This is a short-term hack, the correct thing to do + # is to detect which style of Test::Builder we're dealing with and + # act appropriately. + + my $class = shift; + return bless {}, $class; +} + +sub ok { + my($self, $test, $name) = @_; + + my $ctx = $self->ctx; + + # $test might contain an object which we don't want to accidentally + # store, so we turn it into a boolean. + $test = $test ? 1 : 0; + + lock $Curr_Test; + $Curr_Test++; + + my($pack, $file, $line) = $self->caller; + + my $todo = $self->todo(); + + my $result = {}; + share($result); + + unless( $test ) { + @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + } + else { + @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + } + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if( $todo ) { + my $what_todo = $todo; + $result->{reason} = $what_todo; + $result->{type} = 'todo'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $Test_Results[$Curr_Test-1] = $result; + + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $result->{fail_diag} = (" $msg test ($file at line $line)\n"); + } + + $result->{diag} = ""; + $result->{_level} = $Test::Builder::Level; + $result->{_depth} = Test::Tester::find_run_tests(); + + $ctx->release; + + return $test ? 1 : 0; +} + +sub skip { + my($self, $why) = @_; + $why ||= ''; + + my $ctx = $self->ctx; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + $Test_Results[$Curr_Test-1] = \%result; + + $ctx->release; + return 1; +} + +sub todo_skip { + my($self, $why) = @_; + $why ||= ''; + + my $ctx = $self->ctx; + + lock($Curr_Test); + $Curr_Test++; + + my %result; + share(%result); + %result = ( + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + diag => "", + _level => $Test::Builder::Level, + _depth => Test::Tester::find_run_tests(), + ); + + $Test_Results[$Curr_Test-1] = \%result; + + $ctx->release; + return 1; +} + +sub diag { + my($self, @msgs) = @_; + return unless @msgs; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + my $ctx = $self->ctx; + + # Escape each line with a #. + foreach (@msgs) { + $_ = 'undef' unless defined; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + + my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; + + $result->{diag} .= join("", @msgs); + + $ctx->release; + return 0; +} + +sub details { + return @Test_Results; +} + + +# Stub. Feel free to send me a patch to implement this. +sub note { +} + +sub explain { + return Test::Builder::explain(@_); +} + +sub premature +{ + return $Prem_Diag->{diag}; +} + +sub current_test +{ + if (@_ > 1) + { + die "Don't try to change the test number!"; + } + else + { + return $Curr_Test; + } +} + +sub reset +{ + $Curr_Test = 0; + @Test_Results = (); + $Prem_Diag = {diag => ""}; +} + +1; + +__END__ + +=head1 NAME + +Test::Tester::Capture - Help testing test modules built with Test::Builder + +=head1 DESCRIPTION + +This is a subclass of Test::Builder that overrides many of the methods so +that they don't output anything. It also keeps track of its own set of test +results so that you can use Test::Builder based modules to perform tests on +other Test::Builder based modules. + +=head1 AUTHOR + +Most of the code here was lifted straight from Test::Builder and then had +chunks removed by Fergal Daly . + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/Tester/CaptureRunner.pm ddclient-3.10.0/t/lib/Test/Tester/CaptureRunner.pm --- ddclient-3.9.1/t/lib/Test/Tester/CaptureRunner.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Tester/CaptureRunner.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,79 @@ +# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ +use strict; + +package Test::Tester::CaptureRunner; + +our $VERSION = '1.302175'; + + +use Test::Tester::Capture; +require Exporter; + +sub new +{ + my $pkg = shift; + my $self = bless {}, $pkg; + return $self; +} + +sub run_tests +{ + my $self = shift; + + my $test = shift; + + capture()->reset; + + $self->{StartLevel} = $Test::Builder::Level; + &$test(); +} + +sub get_results +{ + my $self = shift; + my @results = capture()->details; + + my $start = $self->{StartLevel}; + foreach my $res (@results) + { + next if defined $res->{depth}; + my $depth = $res->{_depth} - $res->{_level} - $start - 3; +# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; + $res->{depth} = $depth; + } + + return @results; +} + +sub get_premature +{ + return capture()->premature; +} + +sub capture +{ + return Test::Tester::Capture->new; +} + +__END__ + +=head1 NAME + +Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder + +=head1 DESCRIPTION + +This stuff if needed to allow me to play with other ways of monitoring the +test results. + +=head1 AUTHOR + +Copyright 2003 by Fergal Daly . + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/Tester/Delegate.pm ddclient-3.10.0/t/lib/Test/Tester/Delegate.pm --- ddclient-3.9.1/t/lib/Test/Tester/Delegate.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Tester/Delegate.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,45 @@ +use strict; +use warnings; + +package Test::Tester::Delegate; + +our $VERSION = '1.302175'; + +use Scalar::Util(); + +use vars '$AUTOLOAD'; + +sub new +{ + my $pkg = shift; + + my $obj = shift; + my $self = bless {}, $pkg; + + return $self; +} + +sub AUTOLOAD +{ + my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; + + return if $sub eq "DESTROY"; + + my $obj = $_[0]->{Object}; + + my $ref = $obj->can($sub); + shift(@_); + unshift(@_, $obj); + goto &$ref; +} + +sub can { + my $this = shift; + my ($sub) = @_; + + return $this->{Object}->can($sub) if Scalar::Util::blessed($this); + + return $this->SUPER::can(@_); +} + +1; diff -Nru ddclient-3.9.1/t/lib/Test/Tester.pm ddclient-3.10.0/t/lib/Test/Tester.pm --- ddclient-3.9.1/t/lib/Test/Tester.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/Tester.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,695 @@ +use strict; + +package Test::Tester; + +BEGIN +{ + if (*Test::Builder::new{CODE}) + { + warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" + } +} + +use Test::Builder; +use Test::Tester::CaptureRunner; +use Test::Tester::Delegate; + +require Exporter; + +use vars qw( @ISA @EXPORT ); + +our $VERSION = '1.302175'; + +@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); +@ISA = qw( Exporter ); + +my $Test = Test::Builder->new; +my $Capture = Test::Tester::Capture->new; +my $Delegator = Test::Tester::Delegate->new; +$Delegator->{Object} = $Test; + +my $runner = Test::Tester::CaptureRunner->new; + +my $want_space = $ENV{TESTTESTERSPACE}; + +sub show_space +{ + $want_space = 1; +} + +my $colour = ''; +my $reset = ''; + +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) +{ + if (eval { require Term::ANSIColor; 1 }) + { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms + my ($f, $b) = split(",", $want_colour); + $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); + $reset = Term::ANSIColor::color("reset"); + } + +} + +sub new_new +{ + return $Delegator; +} + +sub capture +{ + return Test::Tester::Capture->new; +} + +sub fh +{ + # experiment with capturing output, I don't like it + $runner = Test::Tester::FHRunner->new; + + return $Test; +} + +sub find_run_tests +{ + my $d = 1; + my $found = 0; + while ((not $found) and (my ($sub) = (caller($d))[3]) ) + { +# print "$d: $sub\n"; + $found = ($sub eq "Test::Tester::run_tests"); + $d++; + } + +# die "Didn't find 'run_tests' in caller stack" unless $found; + return $d; +} + +sub run_tests +{ + local($Delegator->{Object}) = $Capture; + + $runner->run_tests(@_); + + return ($runner->get_premature, $runner->get_results); +} + +sub check_test +{ + my $test = shift; + my $expect = shift; + my $name = shift; + $name = "" unless defined($name); + + @_ = ($test, [$expect], $name); + goto &check_tests; +} + +sub check_tests +{ + my $test = shift; + my $expects = shift; + my $name = shift; + $name = "" unless defined($name); + + my ($prem, @results) = eval { run_tests($test, $name) }; + + $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); + $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || + $Test->diag("Before any testing anything, your tests said\n$prem"); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_results(\@results, $expects, $name); + return ($prem, @results); +} + +sub cmp_field +{ + my ($result, $expect, $field, $desc) = @_; + + if (defined $expect->{$field}) + { + $Test->is_eq($result->{$field}, $expect->{$field}, + "$desc compare $field"); + } +} + +sub cmp_result +{ + my ($result, $expect, $name) = @_; + + my $sub_name = $result->{name}; + $sub_name = "" unless defined($name); + + my $desc = "subtest '$sub_name' of '$name'"; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + cmp_field($result, $expect, "ok", $desc); + + cmp_field($result, $expect, "actual_ok", $desc); + + cmp_field($result, $expect, "type", $desc); + + cmp_field($result, $expect, "reason", $desc); + + cmp_field($result, $expect, "name", $desc); + } + + # if we got no depth then default to 1 + my $depth = 1; + if (exists $expect->{depth}) + { + $depth = $expect->{depth}; + } + + # if depth was explicitly undef then don't test it + if (defined $depth) + { + $Test->is_eq($result->{depth}, $depth, "checking depth") || + $Test->diag('You need to change $Test::Builder::Level'); + } + + if (defined(my $exp = $expect->{diag})) + { + + my $got = ''; + if (ref $exp eq 'Regexp') { + + if (not $Test->like($result->{diag}, $exp, + "subtest '$sub_name' of '$name' compare diag")) + { + $got = $result->{diag}; + } + + } else { + + # if there actually is some diag then put a \n on the end if it's not + # there already + $exp .= "\n" if (length($exp) and $exp !~ /\n$/); + + if (not $Test->ok($result->{diag} eq $exp, + "subtest '$sub_name' of '$name' compare diag")) + { + $got = $result->{diag}; + } + } + + if ($got) { + my $glen = length($got); + my $elen = length($exp); + for ($got, $exp) + { + my @lines = split("\n", $_); + $_ = join("\n", map { + if ($want_space) + { + $_ = $colour.escape($_).$reset; + } + else + { + "'$colour$_$reset'" + } + } @lines); + } + + $Test->diag(<32 and $c<125) or $c == 10) + { + $res .= $char; + } + else + { + $res .= sprintf('\x{%x}', $c) + } + } + return $res; +} + +sub cmp_results +{ + my ($results, $expects, $name) = @_; + + $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); + + for (my $i = 0; $i < @$expects; $i++) + { + my $expect = $expects->[$i]; + my $result = $results->[$i]; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + cmp_result($result, $expect, $name); + } +} + +######## nicked from Test::More +sub plan { + my(@plan) = @_; + + my $caller = caller; + + $Test->exported_to($caller); + + my @imports = (); + foreach my $idx (0..$#plan) { + if( $plan[$idx] eq 'import' ) { + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; + last; + } + } + + $Test->plan(@plan); + + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); +} + +sub import { + my($class) = shift; + { + no warnings 'redefine'; + *Test::Builder::new = \&new_new; + } + goto &plan; +} + +sub _export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + + +############ + +1; + +__END__ + +=head1 NAME + +Test::Tester - Ease testing test modules built with Test::Builder + +=head1 SYNOPSIS + + use Test::Tester tests => 6; + + use Test::MyStyle; + + check_test( + sub { + is_mystyle_eq("this", "that", "not eq"); + }, + { + ok => 0, # expect this to fail + name => "not eq", + diag => "Expected: 'this'\nGot: 'that'", + } + ); + +or + + use Test::Tester tests => 6; + + use Test::MyStyle; + + check_test( + sub { + is_mystyle_qr("this", "that", "not matching"); + }, + { + ok => 0, # expect this to fail + name => "not matching", + diag => qr/Expected: 'this'\s+Got: 'that'/, + } + ); + +or + + use Test::Tester; + + use Test::More tests => 3; + use Test::MyStyle; + + my ($premature, @results) = run_tests( + sub { + is_database_alive("dbname"); + } + ); + + # now use Test::More::like to check the diagnostic output + + like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); + +=head1 DESCRIPTION + +If you have written a test module based on Test::Builder then Test::Tester +allows you to test it with the minimum of effort. + +=head1 HOW TO USE (THE EASY WAY) + +From version 0.08 Test::Tester no longer requires you to included anything +special in your test modules. All you need to do is + + use Test::Tester; + +in your test script B any other Test::Builder based modules and away +you go. + +Other modules based on Test::Builder can be used to help with the +testing. In fact you can even use functions from your module to test +other functions from the same module (while this is possible it is +probably not a good idea, if your module has bugs, then +using it to test itself may give the wrong answers). + +The easiest way to test is to do something like + + check_test( + sub { is_mystyle_eq("this", "that", "not eq") }, + { + ok => 0, # we expect the test to fail + name => "not eq", + diag => "Expected: 'this'\nGot: 'that'", + } + ); + +this will execute the is_mystyle_eq test, capturing its results and +checking that they are what was expected. + +You may need to examine the test results in a more flexible way, for +example, the diagnostic output may be quite long or complex or it may involve +something that you cannot predict in advance like a timestamp. In this case +you can get direct access to the test results: + + my ($premature, @results) = run_tests( + sub { + is_database_alive("dbname"); + } + ); + + like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); + +or + + check_test( + sub { is_mystyle_qr("this", "that", "not matching") }, + { + ok => 0, # we expect the test to fail + name => "not matching", + diag => qr/Expected: 'this'\s+Got: 'that'/, + } + ); + +We cannot predict how long the database ping will take so we use +Test::More's like() test to check that the diagnostic string is of the right +form. + +=head1 HOW TO USE (THE HARD WAY) + +I + +Make your module use the Test::Tester::Capture object instead of the +Test::Builder one. How to do this depends on your module but assuming that +your module holds the Test::Builder object in $Test and that all your test +routines access it through $Test then providing a function something like this + + sub set_builder + { + $Test = shift; + } + +should allow your test scripts to do + + Test::YourModule::set_builder(Test::Tester->capture); + +and after that any tests inside your module will captured. + +=head1 TEST RESULTS + +The result of each test is captured in a hash. These hashes are the same as +the hashes returned by Test::Builder->details but with a couple of extra +fields. + +These fields are documented in L in the details() function + +=over 2 + +=item ok + +Did the test pass? + +=item actual_ok + +Did the test really pass? That is, did the pass come from +Test::Builder->ok() or did it pass because it was a TODO test? + +=item name + +The name supplied for the test. + +=item type + +What kind of test? Possibilities include, skip, todo etc. See +L for more details. + +=item reason + +The reason for the skip, todo etc. See L for more details. + +=back + +These fields are exclusive to Test::Tester. + +=over 2 + +=item diag + +Any diagnostics that were output for the test. This only includes +diagnostics output B the test result is declared. + +Note that Test::Builder ensures that any diagnostics end in a \n and +it in earlier versions of Test::Tester it was essential that you have +the final \n in your expected diagnostics. From version 0.10 onward, +Test::Tester will add the \n if you forgot it. It will not add a \n if +you are expecting no diagnostics. See below for help tracking down +hard to find space and tab related problems. + +=item depth + +This allows you to check that your test module is setting the correct value +for $Test::Builder::Level and thus giving the correct file and line number +when a test fails. It is calculated by looking at caller() and +$Test::Builder::Level. It should count how many subroutines there are before +jumping into the function you are testing. So for example in + + run_tests( sub { my_test_function("a", "b") } ); + +the depth should be 1 and in + + sub deeper { my_test_function("a", "b") } + + run_tests(sub { deeper() }); + +depth should be 2, that is 1 for the sub {} and one for deeper(). This +might seem a little complex but if your tests look like the simple +examples in this doc then you don't need to worry as the depth will +always be 1 and that's what Test::Tester expects by default. + +B: if you do not specify a value for depth in check_test() then it +automatically compares it against 1, if you really want to skip the depth +test then pass in undef. + +B: depth will not be correctly calculated for tests that run from a +signal handler or an END block or anywhere else that hides the call stack. + +=back + +Some of Test::Tester's functions return arrays of these hashes, just +like Test::Builder->details. That is, the hash for the first test will +be array element 1 (not 0). Element 0 will not be a hash it will be a +string which contains any diagnostic output that came before the first +test. This should usually be empty, if it's not, it means something +output diagnostics before any test results showed up. + +=head1 SPACES AND TABS + +Appearances can be deceptive, especially when it comes to emptiness. If you +are scratching your head trying to work out why Test::Tester is saying that +your diagnostics are wrong when they look perfectly right then the answer is +probably whitespace. From version 0.10 on, Test::Tester surrounds the +expected and got diag values with single quotes to make it easier to spot +trailing whitespace. So in this example + + # Got diag (5 bytes): + # 'abcd ' + # Expected diag (4 bytes): + # 'abcd' + +it is quite clear that there is a space at the end of the first string. +Another way to solve this problem is to use colour and inverse video on an +ANSI terminal, see below COLOUR below if you want this. + +Unfortunately this is sometimes not enough, neither colour nor quotes will +help you with problems involving tabs, other non-printing characters and +certain kinds of problems inherent in Unicode. To deal with this, you can +switch Test::Tester into a mode whereby all "tricky" characters are shown as +\{xx}. Tricky characters are those with ASCII code less than 33 or higher +than 126. This makes the output more difficult to read but much easier to +find subtle differences between strings. To turn on this mode either call +C in your test script or set the C environment +variable to be a true value. The example above would then look like + + # Got diag (5 bytes): + # abcd\x{20} + # Expected diag (4 bytes): + # abcd + +=head1 COLOUR + +If you prefer to use colour as a means of finding tricky whitespace +characters then you can set the C environment variable to a +comma separated pair of colours, the first for the foreground, the second +for the background. For example "white,red" will print white text on a red +background. This requires the Term::ANSIColor module. You can specify any +colour that would be acceptable to the Term::ANSIColor::color function. + +If you spell colour differently, that's no problem. The C +variable also works (if both are set then the British spelling wins out). + +=head1 EXPORTED FUNCTIONS + +=head3 ($premature, @results) = run_tests(\&test_sub) + +\&test_sub is a reference to a subroutine. + +run_tests runs the subroutine in $test_sub and captures the results of any +tests inside it. You can run more than 1 test inside this subroutine if you +like. + +$premature is a string containing any diagnostic output from before +the first test. + +@results is an array of test result hashes. + +=head3 cmp_result(\%result, \%expect, $name) + +\%result is a ref to a test result hash. + +\%expect is a ref to a hash of expected values for the test result. + +cmp_result compares the result with the expected values. If any differences +are found it outputs diagnostics. You may leave out any field from the +expected result and cmp_result will not do the comparison of that field. + +=head3 cmp_results(\@results, \@expects, $name) + +\@results is a ref to an array of test results. + +\@expects is a ref to an array of hash refs. + +cmp_results checks that the results match the expected results and if any +differences are found it outputs diagnostics. It first checks that the +number of elements in \@results and \@expects is the same. Then it goes +through each result checking it against the expected result as in +cmp_result() above. + +=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) + +\&test_sub is a reference to a subroutine. + +\@expect is a ref to an array of hash refs which are expected test results. + +check_tests combines run_tests and cmp_tests into a single call. It also +checks if the tests died at any stage. + +It returns the same values as run_tests, so you can further examine the test +results if you need to. + +=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) + +\&test_sub is a reference to a subroutine. + +\%expect is a ref to an hash of expected values for the test result. + +check_test is a wrapper around check_tests. It combines run_tests and +cmp_tests into a single call, checking if the test died. It assumes +that only a single test is run inside \&test_sub and include a test to +make sure this is true. + +It returns the same values as run_tests, so you can further examine the test +results if you need to. + +=head3 show_space() + +Turn on the escaping of characters as described in the SPACES AND TABS +section. + +=head1 HOW IT WORKS + +Normally, a test module (let's call it Test:MyStyle) calls +Test::Builder->new to get the Test::Builder object. Test::MyStyle calls +methods on this object to record information about test results. When +Test::Tester is loaded, it replaces Test::Builder's new() method with one +which returns a Test::Tester::Delegate object. Most of the time this object +behaves as the real Test::Builder object. Any methods that are called are +delegated to the real Test::Builder object so everything works perfectly. +However once we go into test mode, the method calls are no longer passed to +the real Test::Builder object, instead they go to the Test::Tester::Capture +object. This object seems exactly like the real Test::Builder object, +except, instead of outputting test results and diagnostics, it just records +all the information for later analysis. + +=head1 CAVEATS + +Support for calling Test::Builder->note is minimal. It's implemented +as an empty stub, so modules that use it will not crash but the calls +are not recorded for testing purposes like the others. Patches +welcome. + +=head1 SEE ALSO + +L the source of testing goodness. L +for an alternative approach to the problem tackled by Test::Tester - +captures the strings output by Test::Builder. This means you cannot get +separate access to the individual pieces of information and you must predict +B what your test will output. + +=head1 AUTHOR + +This module is copyright 2005 Fergal Daly , some parts +are based on other people's work. + +Plan handling lifted from Test::More. written by Michael G Schwern +. + +Test::Tester::Capture is a cut down and hacked up version of Test::Builder. +Test::Builder was written by chromatic and Michael G +Schwern . + +=head1 LICENSE + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=cut diff -Nru ddclient-3.9.1/t/lib/Test/use/ok.pm ddclient-3.10.0/t/lib/Test/use/ok.pm --- ddclient-3.9.1/t/lib/Test/use/ok.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test/use/ok.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,64 @@ +package Test::use::ok; +use 5.005; + +our $VERSION = '1.302175'; + + +__END__ + +=head1 NAME + +Test::use::ok - Alternative to Test::More::use_ok + +=head1 SYNOPSIS + + use ok 'Some::Module'; + +=head1 DESCRIPTION + +According to the B documentation, it is recommended to run +C inside a C block, so functions are exported at +compile-time and prototypes are properly honored. + +That is, instead of writing this: + + use_ok( 'Some::Module' ); + use_ok( 'Other::Module' ); + +One should write this: + + BEGIN { use_ok( 'Some::Module' ); } + BEGIN { use_ok( 'Other::Module' ); } + +However, people often either forget to add C, or mistakenly group +C with other tests in a single C block, which can create subtle +differences in execution order. + +With this module, simply change all C in test scripts to C, +and they will be executed at C time. The explicit space after C +makes it clear that this is a single compile-time action. + +=head1 SEE ALSO + +L + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=encoding utf8 + +=head1 CC0 1.0 Universal + +To the extent possible under law, 唐鳳 has waived all copyright and related +or neighboring rights to L. + +This work is published from Taiwan. + +L + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/API/Breakage.pm ddclient-3.10.0/t/lib/Test2/API/Breakage.pm --- ddclient-3.9.1/t/lib/Test2/API/Breakage.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/API/Breakage.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,180 @@ +package Test2::API::Breakage; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Test2::Util qw/pkg_to_file/; + +our @EXPORT_OK = qw{ + upgrade_suggested + upgrade_required + known_broken +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub upgrade_suggested { + return ( + 'Test::Exception' => '0.42', + 'Test::FITesque' => '0.04', + 'Test::Module::Used' => '0.2.5', + 'Test::Moose::More' => '0.025', + ); +} + +sub upgrade_required { + return ( + 'Test::Builder::Clutch' => '0.07', + 'Test::Dist::VersionSync' => '1.1.4', + 'Test::Modern' => '0.012', + 'Test::SharedFork' => '0.34', + 'Test::Alien' => '0.04', + 'Test::UseAllModules' => '0.14', + 'Test::More::Prefix' => '0.005', + + 'Test2::Tools::EventDumper' => 0.000007, + 'Test2::Harness' => 0.000013, + + 'Test::DBIx::Class::Schema' => '1.0.9', + 'Test::Clustericious::Cluster' => '0.30', + ); +} + +sub known_broken { + return ( + 'Net::BitTorrent' => '0.052', + 'Test::Able' => '0.11', + 'Test::Aggregate' => '0.373', + 'Test::Flatten' => '0.11', + 'Test::Group' => '0.20', + 'Test::ParallelSubtest' => '0.05', + 'Test::Pretty' => '0.32', + 'Test::Wrapper' => '0.3.0', + + 'Log::Dispatch::Config::TestLog' => '0.02', + ); +} + +# Not reportable: +# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. + +sub report { + my $class = shift; + my ($require) = @_; + + my %suggest = __PACKAGE__->upgrade_suggested(); + my %required = __PACKAGE__->upgrade_required(); + my %broken = __PACKAGE__->known_broken(); + + my @warn; + for my $mod (keys %suggest) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $suggest{$mod}; + next if eval { $mod->VERSION($want); 1 }; + my $error = $@; + chomp $error; + push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}"; + } + + for my $mod (keys %required) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $required{$mod}; + next if eval { $mod->VERSION($want); 1 }; + push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; + } + + for my $mod (keys %broken) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $tested = $broken{$mod}; + push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; + } + + return @warn; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Breakage - What breaks at what version + +=head1 DESCRIPTION + +This module provides lists of modules that are broken, or have been broken in +the past, when upgrading L to use L. + +=head1 FUNCTIONS + +These can be imported, or called as methods on the class. + +=over 4 + +=item %mod_ver = upgrade_suggested() + +=item %mod_ver = Test2::API::Breakage->upgrade_suggested() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade would be a good idea, but not strictly necessary. + +=item %mod_ver = upgrade_required() + +=item %mod_ver = Test2::API::Breakage->upgrade_required() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade is required for the module to work properly. + +=item %mod_ver = known_broken() + +=item %mod_ver = Test2::API::Breakage->known_broken() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then the module will not work. A newer version may work, but is +not tested or verified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/API/Context.pm ddclient-3.10.0/t/lib/Test2/API/Context.pm --- ddclient-3.9.1/t/lib/Test2/API/Context.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/API/Context.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,1019 @@ +package Test2::API::Context; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Carp qw/confess croak/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/get_tid try pkg_to_file get_tid/; + +use Test2::EventFacet::Trace(); +use Test2::API(); + +# Preload some key event types +my %LOADED = ( + map { + my $pkg = "Test2::Event::$_"; + my $file = "Test2/Event/$_.pm"; + require $file unless $INC{$file}; + ( $pkg => $pkg, $_ => $pkg ) + } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/ +); + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + stack hub trace _on_release _depth _is_canon _is_spawn _aborted + errno eval_error child_error thrown +}; + +# Private, not package vars +# It is safe to cache these. +my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); +my $CONTEXTS = Test2::API::_contexts_ref(); + +sub init { + my $self = shift; + + confess "The 'trace' attribute is required" + unless $self->{+TRACE}; + + confess "The 'hub' attribute is required" + unless $self->{+HUB}; + + $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; + + $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; + $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; + $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; +} + +sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } + +sub restore_error_vars { + my $self = shift; + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; +} + +sub DESTROY { + return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; + return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; + my ($self) = @_; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + # Do not show the warning if it looks like an exception has been thrown, or + # if the context is not local to this process or thread. + { + # Sometimes $@ is uninitialized, not a problem in this case so do not + # show the warning about using eq. + no warnings 'uninitialized'; + if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { + require Carp; + my $mess = Carp::longmess("Context destroyed"); + my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; + warn <<" EOT"; +A context appears to have been destroyed without first calling release(). +Based on \$@ it does not look like an exception was thrown (this is not always +a reliable test) + +This is a problem because the global error variables (\$!, \$@, and \$?) will +not be restored. In addition some release callbacks will not work properly from +inside a DESTROY method. + +Here are the context creation details, just in case a tool forgot to call +release(): + File: $frame->[1] + Line: $frame->[2] + Tool: $frame->[3] + +Here is a trace to the code that caused the context to be destroyed, this could +be an exit(), a goto, or simply the end of a scope: +$mess + +Cleaning up the CONTEXT stack... + EOT + } + } + + return if $self->{+_IS_SPAWN}; + + # Remove the key itself to avoid a slow memory leak + delete $CONTEXTS->{$hid}; + $self->{+_IS_CANON} = undef; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; +} + +# release exists to implement behaviors like die-on-fail. In die-on-fail you +# want to die after a failure, but only after diagnostics have been reported. +# The ideal time for the die to happen is when the context is released. +# Unfortunately die does not work in a DESTROY block. +sub release { + my ($self) = @_; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef + if $self->{+_IS_SPAWN}; + + croak "release() should not be called on context that is neither canon nor a child" + unless $self->{+_IS_CANON}; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + croak "context thinks it is canon, but it is not" + unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; + + # Remove the key itself to avoid a slow memory leak + $self->{+_IS_CANON} = undef; + delete $CONTEXTS->{$hid}; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; + + # Do this last so that nothing else changes them. + # If one of the hooks dies then these do not get restored, this is + # intentional + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; + + return; +} + +sub do_in_context { + my $self = shift; + my ($sub, @args) = @_; + + # We need to update the pid/tid and error vars. + my $clone = $self->snapshot; + @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); + $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); + + my $hub = $clone->{+HUB}; + my $hid = $hub->hid; + + my $old = $CONTEXTS->{$hid}; + + $clone->{+_IS_CANON} = 1; + $CONTEXTS->{$hid} = $clone; + weaken($CONTEXTS->{$hid}); + my ($ok, $err) = &try($sub, @args); + my ($rok, $rerr) = try { $clone->release }; + delete $clone->{+_IS_CANON}; + + if ($old) { + $CONTEXTS->{$hid} = $old; + weaken($CONTEXTS->{$hid}); + } + else { + delete $CONTEXTS->{$hid}; + } + + die $err unless $ok; + die $rerr unless $rok; +} + +sub done_testing { + my $self = shift; + $self->hub->finalize($self->trace, 1); + return; +} + +sub throw { + my ($self, $msg) = @_; + $self->{+THROWN} = 1; + ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; + $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; + $self->trace->throw($msg); +} + +sub alert { + my ($self, $msg) = @_; + $self->trace->alert($msg); +} + +sub send_ev2_and_release { + my $self = shift; + my $out = $self->send_ev2(@_); + $self->release; + return $out; +} + +sub send_ev2 { + my $self = shift; + + my $e; + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $e = Test2::Event::V2->new( + trace => $self->{+TRACE}->snapshot, + @_, + ); + } + + if ($self->{+_ABORTED}) { + my $f = $e->facet_data; + ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); + } + $self->{+HUB}->send($e); +} + +sub build_ev2 { + my $self = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + Test2::Event::V2->new( + trace => $self->{+TRACE}->snapshot, + @_, + ); +} + +sub send_event_and_release { + my $self = shift; + my $out = $self->send_event(@_); + $self->release; + return $out; +} + +sub send_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + my $e; + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $e = $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); + } + + if ($self->{+_ABORTED}) { + my $f = $e->facet_data; + ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); + } + $self->{+HUB}->send($e); +} + +sub build_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); +} + +sub pass { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + return $e; +} + +sub pass_and_release { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + $self->release; + return 1; +} + +sub fail { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + for my $msg (@diag) { + if (ref($msg) eq 'Test2::EventFacet::Info::Table') { + $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); + } + else { + $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); + } + } + + $self->{+HUB}->send($e); + return $e; +} + +sub fail_and_release { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + for my $msg (@diag) { + if (ref($msg) eq 'Test2::EventFacet::Info::Table') { + $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); + } + else { + $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); + } + } + + $self->{+HUB}->send($e); + $self->release; + return 0; +} + +sub ok { + my $self = shift; + my ($pass, $name, $on_fail) = @_; + + my $hub = $self->{+HUB}; + + my $e = bless { + trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + pass => $pass, + name => $name, + }, 'Test2::Event::Ok'; + $e->init; + + $hub->send($e); + return $e if $pass; + + $self->failure_diag($e); + + if ($on_fail && @$on_fail) { + $self->diag($_) for @$on_fail; + } + + return $e; +} + +sub failure_diag { + my $self = shift; + my ($e) = @_; + + # Figure out the debug info, this is typically the file name and line + # number, but can also be a custom message. If no trace object is provided + # then we have nothing useful to display. + my $name = $e->name; + my $trace = $e->trace; + my $debug = $trace ? $trace->debug : "[No trace info available]"; + + # Create the initial diagnostics. If the test has a name we put the debug + # info on a second line, this behavior is inherited from Test::Builder. + my $msg = defined($name) + ? qq[Failed test '$name'\n$debug.\n] + : qq[Failed test $debug.\n]; + + $self->diag($msg); +} + +sub skip { + my $self = shift; + my ($name, $reason, @extra) = @_; + $self->send_event( + 'Skip', + name => $name, + reason => $reason, + pass => 1, + @extra, + ); +} + +sub note { + my $self = shift; + my ($message) = @_; + $self->send_event('Note', message => $message); +} + +sub diag { + my $self = shift; + my ($message) = @_; + my $hub = $self->{+HUB}; + $self->send_event( + 'Diag', + message => $message, + ); +} + +sub plan { + my ($self, $max, $directive, $reason) = @_; + $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); +} + +sub bail { + my ($self, $reason) = @_; + $self->send_event('Bail', reason => $reason); +} + +sub _parse_event { + my $self = shift; + my $event = shift; + + my $pkg; + if ($event =~ m/^\+(.*)/) { + $pkg = $1; + } + else { + $pkg = "Test2::Event::$event"; + } + + unless ($LOADED{$pkg}) { + my $file = pkg_to_file($pkg); + my ($ok, $err) = try { require $file }; + $self->throw("Could not load event module '$pkg': $err") + unless $ok; + + $LOADED{$pkg} = $pkg; + } + + confess "'$pkg' is not a subclass of 'Test2::Event'" + unless $pkg->isa('Test2::Event'); + + $LOADED{$event} = $pkg; + + return $pkg; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Context - Object to represent a testing context. + +=head1 DESCRIPTION + +The context object is the primary interface for authors of testing tools +written with L. The context object represents the context in +which a test takes place (File and Line Number), and provides a quick way to +generate events from that context. The context object also takes care of +sending events to the correct L instance. + +=head1 SYNOPSIS + +In general you will not be creating contexts directly. To obtain a context you +should always use C which is exported by the L module. + + use Test2::API qw/context/; + + sub my_ok { + my ($bool, $name) = @_; + my $ctx = context(); + + if ($bool) { + $ctx->pass($name); + } + else { + $ctx->fail($name); + } + + $ctx->release; # You MUST do this! + return $bool; + } + +Context objects make it easy to wrap other tools that also use context. Once +you grab a context, any tool you call before releasing your context will +inherit it: + + sub wrapper { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->diag("wrapping my_ok"); + + my $out = my_ok($bool, $name); + $ctx->release; # You MUST do this! + return $out; + } + +=head1 CRITICAL DETAILS + +=over 4 + +=item you MUST always use the context() sub from Test2::API + +Creating your own context via C<< Test2::API::Context->new() >> will almost never +produce a desirable result. Use C which is exported by L. + +There are a handful of cases where a tool author may want to create a new +context by hand, which is why the C method exists. Unless you really know +what you are doing you should avoid this. + +=item You MUST always release the context when done with it + +Releasing the context tells the system you are done with it. This gives it a +chance to run any necessary callbacks or cleanup tasks. If you forget to +release the context it will try to detect the problem and warn you about it. + +=item You MUST NOT pass context objects around + +When you obtain a context object it is made specifically for your tool and any +tools nested within. If you pass a context around you run the risk of polluting +other tools with incorrect context information. + +If you are certain that you want a different tool to use the same context you +may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of +the context that is safe to pass around or store. + +=item You MUST NOT store or cache a context for later + +As long as a context exists for a given hub, all tools that try to get a +context will get the existing instance. If you try to store the context you +will pollute other tools with incorrect context information. + +If you are certain that you want to save the context for later, you can use a +snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context +that is safe to pass around or store. + +C has some mechanisms to protect you if you do cause a context to +persist beyond the scope in which it was obtained. In practice you should not +rely on these protections, and they are fairly noisy with warnings. + +=item You SHOULD obtain your context as soon as possible in a given tool + +You never know what tools you call from within your own tool will need a +context. Obtaining the context early ensures that nested tools can find the +context you want them to find. + +=back + +=head1 METHODS + +=over 4 + +=item $ctx->done_testing; + +Note that testing is finished. If no plan has been set this will generate a +Plan event. + +=item $clone = $ctx->snapshot() + +This will return a shallow clone of the context. The shallow clone is safe to +store for later. + +=item $ctx->release() + +This will release the context. This runs cleanup tasks, and several important +hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the +context was created. + +B If a context is acquired more than once an internal refcount is kept. +C decrements the ref count, none of the other actions of +C will occur unless the refcount hits 0. This means only the last +call to C will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. + +=item $ctx->throw($message) + +This will throw an exception reporting to the file and line number of the +context. This will also release the context for you. + +=item $ctx->alert($message) + +This will issue a warning from the file and line number of the context. + +=item $stack = $ctx->stack() + +This will return the L instance the context used to find +the current hub. + +=item $hub = $ctx->hub() + +This will return the L instance the context recognizes as the +current one to which all events should be sent. + +=item $dbg = $ctx->trace() + +This will return the L instance used by the context. + +=item $ctx->do_in_context(\&code, @args); + +Sometimes you have a context that is not current, and you want things to use it +as the current one. In these cases you can call +C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and +anything inside of it that looks for a context will find the one on which the +method was called. + +This B affect context on other hubs, only the hub used by the context +will be affected. + + my $ctx = ...; + $ctx->do_in_context(sub { + my $ctx = context(); # returns the $ctx the sub is called on + }); + +B The context will actually be cloned, the clone will be used instead of +the original. This allows the thread id, process id, and error variables to be correct without +modifying the original context. + +=item $ctx->restore_error_vars() + +This will set C<$!>, C<$?>, and C<$@> to what they were when the context was +created. There is no localization or anything done here, calling this method +will actually set these vars. + +=item $! = $ctx->errno() + +The (numeric) value of C<$!> when the context was created. + +=item $? = $ctx->child_error() + +The value of C<$?> when the context was created. + +=item $@ = $ctx->eval_error() + +The value of C<$@> when the context was created. + +=back + +=head2 EVENT PRODUCTION METHODS + +B + +The C and C are optimal if they meet your situation, using one of +them will always be the most optimal. That said they are optimal by eliminating +many features. + +Method such as C, and C are shortcuts for generating common 1-task +events based on the old API, however they are forward compatible, and easy to +use. If these meet your needs then go ahead and use them, but please check back +often for alternatives that may be added. + +If you want to generate new style events, events that do many things at once, +then you want the C<*ev2*> methods. These let you directly specify which facets +you wish to use. + +=over 4 + +=item $event = $ctx->pass() + +=item $event = $ctx->pass($name) + +This will send and return an L event. You may optionally +provide a C<$name> for the assertion. + +The L is a specially crafted and optimized event, using +this will help the performance of passing tests. + +=item $true = $ctx->pass_and_release() + +=item $true = $ctx->pass_and_release($name) + +This is a combination of C and C. You can use this if you do +not plan to do anything with the context after sending the event. This helps +write more clear and compact code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->pass_and_release($name) if $bool; + + ... Handle a failure ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + if ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a failure ... + } + +=item my $event = $ctx->fail() + +=item my $event = $ctx->fail($name) + +=item my $event = $ctx->fail($name, @diagnostics) + +This lets you send an L event. You may optionally provide a +C<$name> and C<@diagnostics> messages. + +Diagnostics messages can be simple strings, data structures, or instances of +L (which are converted inline into the +L structure). + +=item my $false = $ctx->fail_and_release() + +=item my $false = $ctx->fail_and_release($name) + +=item my $false = $ctx->fail_and_release($name, @diagnostics) + +This is a combination of C and C. This can be used to write +clearer and shorter code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->fail_and_release($name) unless $bool; + + ... Handle a success ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + unless ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a success ... + } + + +=item $event = $ctx->ok($bool, $name) + +=item $event = $ctx->ok($bool, $name, \@on_fail) + +B Use of this method is discouraged in favor of C and C +which produce L and L events. These +newer event types are faster and less crufty. + +This will create an L object for you. If C<$bool> is false +then an L event will be sent as well with details about the +failure. If you do not want automatic diagnostics you should use the +C method directly. + +The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in +the event of a test failure. Unlike with C these diagnostics must be +plain strings, data structures are not supported. + +=item $event = $ctx->note($message) + +Send an L. This event prints a message to STDOUT. + +=item $event = $ctx->diag($message) + +Send an L. This event prints a message to STDERR. + +=item $event = $ctx->plan($max) + +=item $event = $ctx->plan(0, 'SKIP', $reason) + +This can be used to send an L event. This event +usually takes either a number of tests you expect to run. Optionally you can +set the expected count to 0 and give the 'SKIP' directive with a reason to +cause all tests to be skipped. + +=item $event = $ctx->skip($name, $reason); + +Send an L event. + +=item $event = $ctx->bail($reason) + +This sends an L event. This event will completely +terminate all testing. + +=item $event = $ctx->send_ev2(%facets) + +This lets you build and send a V2 event directly from facets. The event is +returned after it is sent. + +This example sends a single assertion, a note (comment for stdout in +Test::Builder talk) and sets the plan to 1. + + my $event = $ctx->send_event( + plan => {count => 1}, + assert => {pass => 1, details => "A passing assert"}, + info => [{tag => 'NOTE', details => "This is a note"}], + ); + +=item $event = $ctx->build_e2(%facets) + +This is the same as C, except it builds and returns the event +without sending it. + +=item $event = $ctx->send_ev2_and_release($Type, %parameters) + +This is a combination of C and C. + + sub shorthand { + my $ctx = context(); + return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'}); + } + + sub longform { + my $ctx = context(); + my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'}); + $ctx->release; + return $event; + } + +=item $event = $ctx->send_event($Type, %parameters) + +B + +This lets you build and send an event of any type. The C<$Type> argument should +be the event package name with C left off, or a fully +qualified package name prefixed with a '+'. The event is returned after it is +sent. + + my $event = $ctx->send_event('Ok', ...); + +or + + my $event = $ctx->send_event('+Test2::Event::Ok', ...); + +=item $event = $ctx->build_event($Type, %parameters) + +B + +This is the same as C, except it builds and returns the event +without sending it. + +=item $event = $ctx->send_event_and_release($Type, %parameters) + +B + +This is a combination of C and C. + + sub shorthand { + my $ctx = context(); + return $ctx->send_event_and_release(Pass => { name => 'foo' }); + } + + sub longform { + my $ctx = context(); + my $event = $ctx->send_event(Pass => { name => 'foo' }); + $ctx->release; + return $event; + } + +=back + +=head1 HOOKS + +There are 2 types of hooks, init hooks, and release hooks. As the names +suggest, these hooks are triggered when contexts are created or released. + +=head2 INIT HOOKS + +These are called whenever a context is initialized. That means when a new +instance is created. These hooks are B called every time something +requests a context, just when a new one is created. + +=head3 GLOBAL + +This is how you add a global init callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add an init callback for all contexts created for a given hub. +These callbacks will not run for other hubs. + + $hub->add_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you specify an init hook that will only run if your call to +C generates a new context. The callback will be ignored if +C is returning an existing context. + + my $ctx = context(on_init => sub { + my $ctx = shift; + ... + }); + +=head2 RELEASE HOOKS + +These are called whenever a context is released. That means when the last +reference to the instance is about to be destroyed. These hooks are B +called every time C<< $ctx->release >> is called. + +=head3 GLOBAL + +This is how you add a global release callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add a release callback for all contexts created for a given +hub. These callbacks will not run for other hubs. + + $hub->add_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you add release callbacks directly to a context. The callback will +B be added to the context that gets returned, it does not matter if a +new one is generated, or if an existing one is returned. + + my $ctx = context(on_release => sub { + my $ctx = shift; + ... + }); + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/API/Instance.pm ddclient-3.10.0/t/lib/Test2/API/Instance.pm --- ddclient-3.9.1/t/lib/Test2/API/Instance.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/API/Instance.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,822 @@ +package Test2::API::Instance; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; +use Carp qw/confess carp/; +use Scalar::Util qw/reftype/; + +use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/; + +use Test2::EventFacet::Trace(); +use Test2::API::Stack(); + +use Test2::Util::HashBase qw{ + _pid _tid + no_wait + finalized loaded + ipc stack formatter + contexts + + add_uuid_via + + -preload + + ipc_disabled + ipc_polling + ipc_drivers + ipc_timeout + formatters + + exit_callbacks + post_load_callbacks + context_acquire_callbacks + context_init_callbacks + context_release_callbacks + pre_subtest_callbacks +}; + +sub DEFAULT_IPC_TIMEOUT() { 30 } + +sub pid { $_[0]->{+_PID} } +sub tid { $_[0]->{+_TID} } + +# Wrap around the getters that should call _finalize. +BEGIN { + for my $finalizer (IPC, FORMATTER) { + my $orig = __PACKAGE__->can($finalizer); + my $new = sub { + my $self = shift; + $self->_finalize unless $self->{+FINALIZED}; + $self->$orig; + }; + + no strict 'refs'; + no warnings 'redefine'; + *{$finalizer} = $new; + } +} + +sub has_ipc { !!$_[0]->{+IPC} } + +sub import { + my $class = shift; + return unless @_; + my ($ref) = @_; + $$ref = $class->new; +} + +sub init { $_[0]->reset } + +sub start_preload { + my $self = shift; + + confess "preload cannot be started, Test2::API has already been initialized" + if $self->{+FINALIZED} || $self->{+LOADED}; + + return $self->{+PRELOAD} = 1; +} + +sub stop_preload { + my $self = shift; + + return 0 unless $self->{+PRELOAD}; + $self->{+PRELOAD} = 0; + + $self->post_preload_reset(); + + return 1; +} + +sub post_preload_reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA}; + + $self->{+CONTEXTS} = {}; + + $self->{+FORMATTERS} = []; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; + + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + + $self->{+LOADED} = 0; + + $self->{+STACK} ||= Test2::API::Stack->new; +} + +sub reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+ADD_UUID_VIA} = undef; + + $self->{+CONTEXTS} = {}; + + $self->{+IPC_DRIVERS} = []; + $self->{+IPC_POLLING} = undef; + + $self->{+FORMATTERS} = []; + $self->{+FORMATTER} = undef; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; + + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + + $self->{+NO_WAIT} = 0; + $self->{+LOADED} = 0; + + $self->{+EXIT_CALLBACKS} = []; + $self->{+POST_LOAD_CALLBACKS} = []; + $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; + $self->{+CONTEXT_INIT_CALLBACKS} = []; + $self->{+CONTEXT_RELEASE_CALLBACKS} = []; + $self->{+PRE_SUBTEST_CALLBACKS} = []; + + $self->{+STACK} = Test2::API::Stack->new; +} + +sub _finalize { + my $self = shift; + my ($caller) = @_; + $caller ||= [caller(1)]; + + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + + $self->{+FINALIZED} = $caller; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + unless ($self->{+FORMATTER}) { + my ($formatter, $source); + if ($ENV{T2_FORMATTER}) { + $source = "set by the 'T2_FORMATTER' environment variable"; + + if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + $formatter = $1 ? $2 : "Test2::Formatter::$2" + } + else { + $formatter = ''; + } + } + elsif (@{$self->{+FORMATTERS}}) { + ($formatter) = @{$self->{+FORMATTERS}}; + $source = "Most recently added"; + } + else { + $formatter = 'Test2::Formatter::TAP'; + $source = 'default formatter'; + } + + unless (ref($formatter) || $formatter->can('write')) { + my $file = pkg_to_file($formatter); + my ($ok, $err) = try { require $file }; + unless ($ok) { + my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; + my $border = '*' x length($line); + die "\n\n $border\n $line\n $border\n\n$err"; + } + } + + $self->{+FORMATTER} = $formatter; + } + + # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC + # module is loaded. + return if $self->{+IPC_DISABLED}; + return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; + + # Turn on polling by default, people expect it. + $self->enable_ipc_polling; + + unless (@{$self->{+IPC_DRIVERS}}) { + my ($ok, $error) = try { require Test2::IPC::Driver::Files }; + die $error unless $ok; + push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; + } + + for my $driver (@{$self->{+IPC_DRIVERS}}) { + next unless $driver->can('is_viable') && $driver->is_viable; + $self->{+IPC} = $driver->new or next; + return; + } + + die "IPC has been requested, but no viable drivers were found. Aborting...\n"; +} + +sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } + +sub add_formatter { + my $self = shift; + my ($formatter) = @_; + unshift @{$self->{+FORMATTERS}} => $formatter; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::Formatter'} = 1; + + carp "Formatter $formatter loaded too late to be used as the global formatter"; +} + +sub add_context_acquire_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-acquire callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; +} + +sub add_context_init_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-init callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; +} + +sub add_context_release_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-release callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; +} + +sub add_post_load_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Post-load callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+POST_LOAD_CALLBACKS}} => $code; + $code->() if $self->{+LOADED}; +} + +sub add_pre_subtest_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Pre-subtest callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code; +} + +sub load { + my $self = shift; + unless ($self->{+LOADED}) { + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + # END blocks run in reverse order. This insures the END block is loaded + # as late as possible. It will not solve all cases, but it helps. + eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; + + $self->{+LOADED} = 1; + $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; + } + return $self->{+LOADED}; +} + +sub add_exit_callback { + my $self = shift; + my ($code) = @_; + my $rtype = reftype($code) || ""; + + confess "End callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+EXIT_CALLBACKS}} => $code; +} + +sub ipc_disable { + my $self = shift; + + confess "Attempt to disable IPC after it has been initialized" + if $self->{+IPC}; + + $self->{+IPC_DISABLED} = 1; +} + +sub add_ipc_driver { + my $self = shift; + my ($driver) = @_; + unshift @{$self->{+IPC_DRIVERS}} => $driver; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::IPC::Driver'} = 1; + + carp "IPC driver $driver loaded too late to be used as the global ipc driver"; +} + +sub enable_ipc_polling { + my $self = shift; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + $self->add_context_init_callback( + # This is called every time a context is created, it needs to be fast. + # $_[0] is a context object + sub { + return unless $self->{+IPC_POLLING}; + return unless $self->{+IPC}; + return unless $self->{+IPC}->pending(); + return $_[0]->{hub}->cull; + } + ) unless defined $self->ipc_polling; + + $self->set_ipc_polling(1); +} + +sub get_ipc_pending { + my $self = shift; + return -1 unless $self->{+IPC}; + $self->{+IPC}->pending(); +} + +sub _check_pid { + my $self = shift; + my ($pid) = @_; + return kill(0, $pid); +} + +sub set_ipc_pending { + my $self = shift; + return unless $self->{+IPC}; + my ($val) = @_; + + confess "value is required for set_ipc_pending" + unless $val; + + $self->{+IPC}->set_pending($val); +} + +sub disable_ipc_polling { + my $self = shift; + return unless defined $self->{+IPC_POLLING}; + $self->{+IPC_POLLING} = 0; +} + +sub _ipc_wait { + my ($timeout) = @_; + my $fail = 0; + + $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; + + my $ok = eval { + if (CAN_FORK) { + local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; + alarm $timeout; + + while (1) { + my $pid = CORE::wait(); + my $err = $?; + last if $pid == -1; + next unless $err; + $fail++; + + my $sig = $err & 127; + my $exit = $err >> 8; + warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n"; + } + + alarm 0; + } + + if (USE_THREADS) { + my $start = time; + + while (1) { + last unless threads->list(); + die "Timeout waiting on child thread" if time - $start >= $timeout; + sleep 1; + for my $t (threads->list) { + # threads older than 1.34 do not have this :-( + next if $t->can('is_joinable') && !$t->is_joinable; + $t->join; + # In older threads we cannot check if a thread had an error unless + # we control it and its return. + my $err = $t->can('error') ? $t->error : undef; + next unless $err; + my $tid = $t->tid(); + $fail++; + chomp($err); + warn "Thread $tid did not end cleanly: $err\n"; + } + } + } + + 1; + }; + my $error = $@; + + return 0 if $ok && !$fail; + warn $error unless $ok; + return 255; +} + +sub set_exit { + my $self = shift; + + return if $self->{+PRELOAD}; + + my $exit = $?; + my $new_exit = $exit; + + if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { + print STDERR <<" EOT"; + +******************************************************************************** +* * +* Test::Builder -- Test2::API version mismatch detected * +* * +******************************************************************************** + Test2::API Version: $Test2::API::VERSION +Test::Builder Version: $Test::Builder::VERSION + +This is not a supported configuration, you will have problems. + + EOT + } + + for my $ctx (values %{$self->{+CONTEXTS}}) { + next unless $ctx; + + next if $ctx->_aborted && ${$ctx->_aborted}; + + # Only worry about contexts in this PID + my $trace = $ctx->trace || next; + next unless $trace->pid && $trace->pid == $$; + + # Do not worry about contexts that have no hub + my $hub = $ctx->hub || next; + + # Do not worry if the state came to a sudden end. + next if $hub->bailed_out; + next if defined $hub->skip_reason; + + # now we worry + $trace->alert("context object was never released! This means a testing tool is behaving very badly"); + + $exit = 255; + $new_exit = 255; + } + + if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { + $? = $exit; + return; + } + + my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); + + if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { + local $?; + my %seen; + for my $hub (reverse @hubs) { + my $ipc = $hub->ipc or next; + next if $seen{$ipc}++; + $ipc->waiting(); + } + + my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT}); + $new_exit ||= $ipc_exit; + } + + # None of this is necessary if we never got a root hub + if(my $root = shift @hubs) { + my $trace = Test2::EventFacet::Trace->new( + frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], + detail => __PACKAGE__ . ' END Block finalization', + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + if (@hubs) { + $ctx->diag("Test ended with extra hubs on the stack!"); + $new_exit = 255; + } + + unless ($root->no_ending) { + local $?; + $root->finalize($trace) unless $root->ended; + $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; + $new_exit ||= $root->failed; + $new_exit ||= 255 unless $root->is_passing; + } + } + + $new_exit = 255 if $new_exit > 255; + + if ($new_exit && eval { require Test2::API::Breakage; 1 }) { + my @warn = Test2::API::Breakage->report(); + + if (@warn) { + print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; + print STDERR "$_\n" for @warn; + print STDERR "\n"; + } + } + + $? = $new_exit; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Instance - Object used by Test2::API under the hood + +=head1 DESCRIPTION + +This object encapsulates the global shared state tracked by +L. A single global instance of this package is stored (and +obscured) by the L package. + +There is no reason to directly use this package. This package is documented for +completeness. This package can change, or go away completely at any time. +Directly using, or monkeypatching this package is not supported in any way +shape or form. + +=head1 SYNOPSIS + + use Test2::API::Instance; + + my $obj = Test2::API::Instance->new; + +=over 4 + +=item $pid = $obj->pid + +PID of this instance. + +=item $obj->tid + +Thread ID of this instance. + +=item $obj->reset() + +Reset the object to defaults. + +=item $obj->load() + +Set the internal state to loaded, and run and stored post-load callbacks. + +=item $bool = $obj->loaded + +Check if the state is set to loaded. + +=item $arrayref = $obj->post_load_callbacks + +Get the post-load callbacks. + +=item $obj->add_post_load_callback(sub { ... }) + +Add a post-load callback. If C has already been called then the callback will +be immediately executed. If C has not been called then the callback will be +stored and executed later when C is called. + +=item $hashref = $obj->contexts() + +Get a hashref of all active contexts keyed by hub id. + +=item $arrayref = $obj->context_acquire_callbacks + +Get all context acquire callbacks. + +=item $arrayref = $obj->context_init_callbacks + +Get all context init callbacks. + +=item $arrayref = $obj->context_release_callbacks + +Get all context release callbacks. + +=item $arrayref = $obj->pre_subtest_callbacks + +Get all pre-subtest callbacks. + +=item $obj->add_context_init_callback(sub { ... }) + +Add a context init callback. Subs are called every time a context is created. Subs +get the newly created context as their only argument. + +=item $obj->add_context_release_callback(sub { ... }) + +Add a context release callback. Subs are called every time a context is released. Subs +get the released context as their only argument. These callbacks should not +call release on the context. + +=item $obj->add_pre_subtest_callback(sub { ... }) + +Add a pre-subtest callback. Subs are called every time a subtest is +going to be run. Subs get the subtest name, coderef, and any +arguments. + +=item $obj->set_exit() + +This is intended to be called in an C block. This will look at +test state and set $?. This will also call any end callbacks, and wait on child +processes/threads. + +=item $obj->set_ipc_pending($val) + +Tell other processes and threads there is a pending event. C<$val> should be a +unique value no other thread/process will generate. + +B This will also make the current process see a pending event. + +=item $pending = $obj->get_ipc_pending() + +This returns -1 if it is not possible to know. + +This returns 0 if there are no pending events. + +This returns 1 if there are pending events. + +=item $timeout = $obj->ipc_timeout; + +=item $obj->set_ipc_timeout($timeout); + +How long to wait for child processes and threads before aborting. + +=item $drivers = $obj->ipc_drivers + +Get the list of IPC drivers. + +=item $obj->add_ipc_driver($DRIVER_CLASS) + +Add an IPC driver to the list. The most recently added IPC driver will become +the global one during initialization. If a driver is added after initialization +has occurred a warning will be generated: + + "IPC driver $driver loaded too late to be used as the global ipc driver" + +=item $bool = $obj->ipc_polling + +Check if polling is enabled. + +=item $obj->enable_ipc_polling + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item $obj->disable_ipc_polling + +Turn off IPC polling. + +=item $bool = $obj->no_wait + +=item $bool = $obj->set_no_wait($bool) + +Get/Set no_wait. This option is used to turn off process/thread waiting at exit. + +=item $arrayref = $obj->exit_callbacks + +Get the exit callbacks. + +=item $obj->add_exit_callback(sub { ... }) + +Add an exit callback. This callback will be called by C. + +=item $bool = $obj->finalized + +Check if the object is finalized. Finalization happens when either C, +C, or C are called on the object. Once finalization happens +these fields are considered unchangeable (not enforced here, enforced by +L). + +=item $ipc = $obj->ipc + +Get the one true IPC instance. + +=item $obj->ipc_disable + +Turn IPC off + +=item $bool = $obj->ipc_disabled + +Check if IPC is disabled + +=item $stack = $obj->stack + +Get the one true hub stack. + +=item $formatter = $obj->formatter + +Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> +package. This could be any package that implements the C method. This +can also be an instantiated object. + +=item $bool = $obj->formatter_set() + +Check if a formatter has been set. + +=item $obj->add_formatter($class) + +=item $obj->add_formatter($obj) + +Add a formatter. The most recently added formatter will become the global one +during initialization. If a formatter is added after initialization has occurred +a warning will be generated: + + "Formatter $formatter loaded too late to be used as the global formatter" + +=item $obj->set_add_uuid_via(sub { ... }) + +=item $sub = $obj->add_uuid_via() + +This allows you to provide a UUID generator. If provided UUIDs will be attached +to all events, hubs, and contexts. This is useful for storing, tracking, and +linking these objects. + +The sub you provide should always return a unique identifier. Most things will +expect a proper UUID string, however nothing in Test2::API enforces this. + +The sub will receive exactly 1 argument, the type of thing being tagged +'context', 'hub', or 'event'. In the future additional things may be tagged, in +which case new strings will be passed in. These are purely informative, you can +(and usually should) ignore them. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/API/Stack.pm ddclient-3.10.0/t/lib/Test2/API/Stack.pm --- ddclient-3.9.1/t/lib/Test2/API/Stack.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/API/Stack.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,226 @@ +package Test2::API::Stack; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Test2::Hub(); + +use Carp qw/confess/; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub new_hub { + my $self = shift; + my %params = @_; + + my $class = delete $params{class} || 'Test2::Hub'; + + my $hub = $class->new(%params); + + if (@$self) { + $hub->inherit($self->[-1], %params); + } + else { + require Test2::API; + $hub->format(Test2::API::test2_formatter()->new_root) + unless $hub->format || exists($params{formatter}); + + my $ipc = Test2::API::test2_ipc(); + if ($ipc && !$hub->ipc && !exists($params{ipc})) { + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + } + + push @$self => $hub; + + $hub; +} + +sub top { + my $self = shift; + return $self->new_hub unless @$self; + return $self->[-1]; +} + +sub peek { + my $self = shift; + return @$self ? $self->[-1] : undef; +} + +sub cull { + my $self = shift; + $_->cull for reverse @$self; +} + +sub all { + my $self = shift; + return @$self; +} + +sub root { + my $self = shift; + return unless @$self; + return $self->[0]; +} + +sub clear { + my $self = shift; + @$self = (); +} + +# Do these last without keywords in order to prevent them from getting used +# when we want the real push/pop. + +{ + no warnings 'once'; + + *push = sub { + my $self = shift; + my ($hub) = @_; + $hub->inherit($self->[-1]) if @$self; + push @$self => $hub; + }; + + *pop = sub { + my $self = shift; + my ($hub) = @_; + confess "No hubs on the stack" + unless @$self; + confess "You cannot pop the root hub" + if 1 == @$self; + confess "Hub stack mismatch, attempted to pop incorrect hub" + unless $self->[-1] == $hub; + pop @$self; + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Stack - Object to manage a stack of L +instances. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards incompatible ways, but the +underlying implementation details might. B + +=head1 DESCRIPTION + +This module is used to represent and manage a stack of L +objects. Hubs are usually in a stack so that you can push a new hub into place +that can intercept and handle events differently than the primary hub. + +=head1 SYNOPSIS + + my $stack = Test2::API::Stack->new; + my $hub = $stack->top; + +=head1 METHODS + +=over 4 + +=item $stack = Test2::API::Stack->new() + +This will create a new empty stack instance. All arguments are ignored. + +=item $hub = $stack->new_hub() + +=item $hub = $stack->new_hub(%params) + +=item $hub = $stack->new_hub(%params, class => $class) + +This will generate a new hub and push it to the top of the stack. Optionally +you can provide arguments that will be passed into the constructor for the +L object. + +If you specify the C<< 'class' => $class >> argument, the new hub will be an +instance of the specified class. + +Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the +formatter and IPC instance will be inherited from the current top hub. You can +set the parameters to C to avoid having a formatter or IPC instance. + +If there is no top hub, and you do not ask to leave IPC and formatter undef, +then a new formatter will be created, and the IPC instance from +L will be used. + +=item $hub = $stack->top() + +This will return the top hub from the stack. If there is no top hub yet this +will create it. + +=item $hub = $stack->peek() + +This will return the top hub from the stack. If there is no top hub yet this +will return undef. + +=item $stack->cull + +This will call C<< $hub->cull >> on all hubs in the stack. + +=item @hubs = $stack->all + +This will return all the hubs in the stack as a list. + +=item $stack->clear + +This will completely remove all hubs from the stack. Normally you do not want +to do this, but there are a few valid reasons for it. + +=item $stack->push($hub) + +This will push the new hub onto the stack. + +=item $stack->pop($hub) + +This will pop a hub from the stack, if the hub at the top of the stack does not +match the hub you expect (passed in as an argument) it will throw an exception. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/API.pm ddclient-3.10.0/t/lib/Test2/API.pm --- ddclient-3.9.1/t/lib/Test2/API.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/API.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,1689 @@ +package Test2::API; +use strict; +use warnings; + +use Test2::Util qw/USE_THREADS/; + +BEGIN { + $ENV{TEST_ACTIVE} ||= 1; + $ENV{TEST2_ACTIVE} = 1; +} + +our $VERSION = '1.302175'; + + +my $INST; +my $ENDING = 0; +sub test2_unset_is_end { $ENDING = 0 } +sub test2_get_is_end { $ENDING } + +sub test2_set_is_end { + my $before = $ENDING; + ($ENDING) = @_ ? @_ : (1); + + # Only send the event in a transition from false to true + return if $before; + return unless $ENDING; + + return unless $INST; + my $stack = $INST->stack or return; + my $root = $stack->root or return; + + return unless $root->count; + + return unless $$ == $INST->pid; + return unless get_tid() == $INST->tid; + + my $trace = Test2::EventFacet::Trace->new( + frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'], + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' }); + + 1; +} + +use Test2::API::Instance(\$INST); + +# Set the exit status +END { + test2_set_is_end(); # See gh #16 + $INST->set_exit(); +} + +sub CLONE { + my $init = test2_init_done(); + my $load = test2_load_done(); + + return if $init && $load; + + require Carp; + Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; +} + +# See gh #16 +{ + no warnings; + INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } +} + +BEGIN { + no warnings 'once'; + if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { + *DO_DEPTH_CHECK = sub() { 1 }; + } + else { + *DO_DEPTH_CHECK = sub() { 0 }; + } +} + +use Test2::EventFacet::Trace(); +use Test2::Util::Trace(); # Legacy + +use Test2::Hub::Subtest(); +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +use Test2::Event::Ok(); +use Test2::Event::Diag(); +use Test2::Event::Note(); +use Test2::Event::Plan(); +use Test2::Event::Bail(); +use Test2::Event::Exception(); +use Test2::Event::Waiting(); +use Test2::Event::Skip(); +use Test2::Event::Subtest(); + +use Carp qw/carp croak confess/; +use Scalar::Util qw/blessed weaken/; +use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/; + +our @EXPORT_OK = qw{ + context release + context_do + no_context + intercept intercept_deep + run_subtest + + test2_init_done + test2_load_done + test2_load + test2_start_preload + test2_stop_preload + test2_in_preload + test2_is_testing_done + + test2_set_is_end + test2_unset_is_end + test2_get_is_end + + test2_pid + test2_tid + test2_stack + test2_no_wait + test2_ipc_wait_enable + test2_ipc_wait_disable + test2_ipc_wait_enabled + + test2_add_uuid_via + + test2_add_callback_testing_done + + test2_add_callback_context_aquire + test2_add_callback_context_acquire + test2_add_callback_context_init + test2_add_callback_context_release + test2_add_callback_exit + test2_add_callback_post_load + test2_add_callback_pre_subtest + test2_list_context_aquire_callbacks + test2_list_context_acquire_callbacks + test2_list_context_init_callbacks + test2_list_context_release_callbacks + test2_list_exit_callbacks + test2_list_post_load_callbacks + test2_list_pre_subtest_callbacks + + test2_ipc + test2_has_ipc + test2_ipc_disable + test2_ipc_disabled + test2_ipc_drivers + test2_ipc_add_driver + test2_ipc_polling + test2_ipc_disable_polling + test2_ipc_enable_polling + test2_ipc_get_pending + test2_ipc_set_pending + test2_ipc_get_timeout + test2_ipc_set_timeout + + test2_formatter + test2_formatters + test2_formatter_add + test2_formatter_set + + test2_stdout + test2_stderr + test2_reset_io +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $STACK = $INST->stack; +my $CONTEXTS = $INST->contexts; +my $INIT_CBS = $INST->context_init_callbacks; +my $ACQUIRE_CBS = $INST->context_acquire_callbacks; + +my $STDOUT = clone_io(\*STDOUT); +my $STDERR = clone_io(\*STDERR); +sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } +sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } + +sub test2_post_preload_reset { + test2_reset_io(); + $INST->post_preload_reset; +} + +sub test2_reset_io { + $STDOUT = clone_io(\*STDOUT); + $STDERR = clone_io(\*STDERR); +} + +sub test2_init_done { $INST->finalized } +sub test2_load_done { $INST->loaded } + +sub test2_load { $INST->load } +sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } +sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } +sub test2_in_preload { $INST->preload } + +sub test2_pid { $INST->pid } +sub test2_tid { $INST->tid } +sub test2_stack { $INST->stack } +sub test2_ipc_wait_enable { $INST->set_no_wait(0) } +sub test2_ipc_wait_disable { $INST->set_no_wait(1) } +sub test2_ipc_wait_enabled { !$INST->no_wait } + +sub test2_is_testing_done { + # No instance? VERY DONE! + return 1 unless $INST; + + # No stack? tests must be done, it is created pretty early + my $stack = $INST->stack or return 1; + + # Nothing on the stack, no root hub yet, likely have not started testing + return 0 unless @$stack; + + # Stack has a slot for the root hub (see above) but it is undefined, likely + # garbage collected, test is done + my $root_hub = $stack->[0] or return 1; + + # If the root hub is ended than testing is done. + return 1 if $root_hub->ended; + + # Looks like we are still testing! + return 0; +} + +sub test2_no_wait { + $INST->set_no_wait(@_) if @_; + $INST->no_wait; +} + +sub test2_add_callback_testing_done { + my $cb = shift; + + test2_add_callback_post_load(sub { + my $stack = test2_stack(); + $stack->top; # Insure we have a hub + my ($hub) = Test2::API::test2_stack->all; + + $hub->set_active(1); + + $hub->follow_up($cb); + }); + + return; +} + +sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } +sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } +sub test2_add_callback_exit { $INST->add_exit_callback(@_) } +sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } +sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) } +sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } +sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } +sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } +sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } +sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} } + +sub test2_add_uuid_via { + $INST->set_add_uuid_via(@_) if @_; + $INST->add_uuid_via(); +} + +sub test2_ipc { $INST->ipc } +sub test2_has_ipc { $INST->has_ipc } +sub test2_ipc_disable { $INST->ipc_disable } +sub test2_ipc_disabled { $INST->ipc_disabled } +sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } +sub test2_ipc_drivers { @{$INST->ipc_drivers} } +sub test2_ipc_polling { $INST->ipc_polling } +sub test2_ipc_enable_polling { $INST->enable_ipc_polling } +sub test2_ipc_disable_polling { $INST->disable_ipc_polling } +sub test2_ipc_get_pending { $INST->get_ipc_pending } +sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } +sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) } +sub test2_ipc_get_timeout { $INST->ipc_timeout() } +sub test2_ipc_enable_shm { 0 } + +sub test2_formatter { + if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + my $formatter = $1 ? $2 : "Test2::Formatter::$2"; + my $file = pkg_to_file($formatter); + require $file; + return $formatter; + } + + return $INST->formatter; +} + +sub test2_formatters { @{$INST->formatters} } +sub test2_formatter_add { $INST->add_formatter(@_) } +sub test2_formatter_set { + my ($formatter) = @_; + croak "No formatter specified" unless $formatter; + croak "Global Formatter already set" if $INST->formatter_set; + $INST->set_formatter($formatter); +} + +# Private, for use in Test2::API::Context +sub _contexts_ref { $INST->contexts } +sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } +sub _context_init_callbacks_ref { $INST->context_init_callbacks } +sub _context_release_callbacks_ref { $INST->context_release_callbacks } +sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) } + +# Private, for use in Test2::IPC +sub _set_ipc { $INST->set_ipc(@_) } + +sub context_do(&;@) { + my $code = shift; + my @args = @_; + + my $ctx = context(level => 1); + + my $want = wantarray; + + my @out; + my $ok = eval { + $want ? @out = $code->($ctx, @args) : + defined($want) ? $out[0] = $code->($ctx, @args) : + $code->($ctx, @args) ; + 1; + }; + my $err = $@; + + $ctx->release; + + die $err unless $ok; + + return @out if $want; + return $out[0] if defined $want; + return; +} + +sub no_context(&;$) { + my ($code, $hid) = @_; + $hid ||= $STACK->top->hid; + + my $ctx = $CONTEXTS->{$hid}; + delete $CONTEXTS->{$hid}; + my $ok = eval { $code->(); 1 }; + my $err = $@; + + $CONTEXTS->{$hid} = $ctx; + weaken($CONTEXTS->{$hid}); + + die $err unless $ok; + + return; +}; + +my $UUID_VIA = _add_uuid_via_ref(); +sub context { + # We need to grab these before anything else to ensure they are not + # changed. + my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E); + + my %params = (level => 0, wrapped => 0, @_); + + # If something is getting a context then the sync system needs to be + # considered loaded... + $INST->load unless $INST->{loaded}; + + croak "context() called, but return value is ignored" + unless defined wantarray; + + my $stack = $params{stack} || $STACK; + my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); + + # Catch an edge case where we try to get context after the root hub has + # been garbage collected resulting in a stack that has a single undef + # hub + if (!$hub && !exists($params{hub}) && @$stack) { + my $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)"); + + # The error message is usually masked by the global destruction, so we have to print to STDER + print STDERR $msg; + + # Make sure this is a failure, we are probably already in END, so set $? to change the exit code + $? = 1; + + # Now we actually die to interrupt the program flow and avoid undefined his warnings + die $msg; + } + + my $hid = $hub->{hid}; + my $current = $CONTEXTS->{$hid}; + + $_->(\%params) for @$ACQUIRE_CBS; + map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + my $phase = ${^GLOBAL_PHASE} || 'NA'; + my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; + + my $level = 1 + $params{level}; + my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level); + unless ($pkg || $end_phase) { + confess "Could not find context at depth $level" unless $params{fudge}; + ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg); + } + + my $depth = $level; + $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); + $depth -= $params{wrapped}; + my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; + + if ($current && $params{on_release} && $depth_ok) { + $current->{_on_release} ||= []; + push @{$current->{_on_release}} => $params{on_release}; + } + + # I know this is ugly.... + ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless( + { + %$current, + _is_canon => undef, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + _is_spawn => [$pkg, $file, $line, $sub], + }, + 'Test2::API::Context' + ) if $current && $depth_ok; + + # Handle error condition of bad level + if ($current) { + unless (${$current->{_aborted}}) { + _canon_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $current->{_is_canon}; + + _depth_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $depth_ok; + } + + $current->release if $current->{_is_canon}; + + delete $CONTEXTS->{$hid}; + } + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $trace = bless( + { + frame => [$pkg, $file, $line, $sub], + pid => $$, + tid => get_tid(), + cid => gen_uid(), + hid => $hid, + nested => $hub->{nested}, + buffered => $hub->{buffered}, + + $$UUID_VIA ? ( + huuid => $hub->{uuid}, + uuid => ${$UUID_VIA}->('context'), + ) : (), + }, + 'Test2::EventFacet::Trace' + ); + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $aborted = 0; + $current = bless( + { + _aborted => \$aborted, + stack => $stack, + hub => $hub, + trace => $trace, + _is_canon => 1, + _depth => $depth, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + $params{on_release} ? (_on_release => [$params{on_release}]) : (), + }, + 'Test2::API::Context' + ); + + $CONTEXTS->{$hid} = $current; + weaken($CONTEXTS->{$hid}); + + $_->($current) for @$INIT_CBS; + map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; + + $params{on_init}->($current) if $params{on_init}; + + ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error); + + return $current; +} + +sub _depth_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context was created in a stack frame at the same, or deeper level. This usually +means that a tool failed to release the context when it was finished. + EOT +} + +sub _canon_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context has an invalid internal state (!_canon_count). This should not normally +happen unless something is mucking about with internals... + EOT +} + +sub _existing_error { + my ($ctx, $details, $msg) = @_; + my ($pkg, $file, $line, $sub, $depth) = @$details; + + my $oldframe = $ctx->{trace}->frame; + my $olddepth = $ctx->{_depth}; + + # Older versions of Carp do not export longmess() function, so it needs to be called with package name + my $mess = Carp::longmess(); + + warn <<" EOT"; +$msg +Old context details: + File: $oldframe->[1] + Line: $oldframe->[2] + Tool: $oldframe->[3] + Depth: $olddepth + +New context details: + File: $file + Line: $line + Tool: $sub + Depth: $depth + +Trace: $mess + +Removing the old context and creating a new one... + EOT +} + +sub release($;$) { + $_[0]->release; + return $_[1]; +} + +sub intercept(&) { + my $code = shift; + my $ctx = context(); + + my $events = _intercept($code, deep => 0); + + $ctx->release; + + return $events; +} + +sub intercept_deep(&) { + my $code = shift; + my $ctx = context(); + + my $events = _intercept($code, deep => 1); + + $ctx->release; + + return $events; +} + +sub _intercept { + my $code = shift; + my %params = @_; + my $ctx = context(); + + my $ipc; + if (my $global_ipc = test2_ipc()) { + my $driver = blessed($global_ipc); + $ipc = $driver->new; + } + + my $hub = Test2::Hub::Interceptor->new( + ipc => $ipc, + no_ending => 1, + ); + + my @events; + $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep}); + + $ctx->stack->top; # Make sure there is a top hub before we begin. + $ctx->stack->push($hub); + + my ($ok, $err) = (1, undef); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; + $err = $@; + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { + $ok = 1; + $err = undef; + } + } + + $hub->cull; + $ctx->stack->pop($hub); + + my $trace = $ctx->trace; + $ctx->release; + + die $err unless $ok; + + $hub->finalize($trace, 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + return \@events; +} + +sub run_subtest { + my ($name, $code, $params, @args) = @_; + + $_->($name,$code,@args) + for Test2::API::test2_list_pre_subtest_callbacks(); + + $params = {buffered => $params} unless ref $params; + my $inherit_trace = delete $params->{inherit_trace}; + + my $ctx = context(); + + my $parent = $ctx->hub; + + # If a parent is buffered then the child must be as well. + my $buffered = $params->{buffered} || $parent->{buffered}; + + $ctx->note($name) unless $buffered; + + my $stack = $ctx->stack || $STACK; + my $hub = $stack->new_hub( + class => 'Test2::Hub::Subtest', + %$params, + buffered => $buffered, + ); + + my @events; + $hub->listen(sub { push @events => $_[1] }); + + if ($buffered) { + if (my $format = $hub->format) { + my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; + $hub->format(undef) if $hide; + } + } + + if ($inherit_trace) { + my $orig = $code; + $code = sub { + my $base_trace = $ctx->trace; + my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested); + my $st_ctx = Test2::API::Context->new( + trace => $trace, + hub => $hub, + ); + $st_ctx->do_in_context($orig, @args); + }; + } + + my ($ok, $err, $finished); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(@args); 1 }; + $err = $@; + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { + $ok = undef; + $err = undef; + } + else { + $finished = 1; + } + } + + if ($params->{no_fork}) { + if ($$ != $ctx->trace->pid) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } + + if (get_tid() != $ctx->trace->tid) { + warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; + exit 255; + } + } + elsif (!$parent->is_local && !$parent->ipc) { + warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; + exit 255; + } + + $stack->pop($hub); + + my $trace = $ctx->trace; + + my $bailed = $hub->bailed_out; + + if (!$finished) { + if ($bailed && !$buffered) { + $ctx->bail($bailed->reason); + } + elsif ($bailed && $buffered) { + $ok = 1; + } + else { + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + } + + $hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + my $pass = $ok && $hub->is_passing; + my $e = $ctx->build_event( + 'Subtest', + pass => $pass, + name => $name, + subtest_id => $hub->id, + subtest_uuid => $hub->uuid, + buffered => $buffered, + subevents => \@events, + ); + + my $plan_ok = $hub->check_plan; + + $ctx->hub->send($e); + + $ctx->failure_diag($e) unless $e->pass; + + $ctx->diag("Caught exception in subtest: $err") unless $ok; + + $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) + if defined($plan_ok) && !$plan_ok; + + $ctx->bail($bailed->reason) if $bailed && $buffered; + + $ctx->release; + return $pass; +} + +# There is a use-cycle between API and API/Context. Context needs to use some +# API functions as the package is compiling. Test2::API::context() needs +# Test2::API::Context to be loaded, but we cannot 'require' the module there as +# it causes a very noticeable performance impact with how often context() is +# called. +require Test2::API::Context; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API - Primary interface for writing Test2 based testing tools. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards-incompatible ways (once there is +a stable release), but the underlying implementation details might. +B + +Currently the implementation is to create a single instance of the +L Object. All class methods defer to the single +instance. There is no public access to the singleton, and that is intentional. +The class methods provided by this package provide the only functionality +publicly exposed. + +This is done primarily to avoid the problems Test::Builder had by exposing its +singleton. We do not want anyone to replace this singleton, rebless it, or +directly muck with its internals. If you need to do something and cannot +because of the restrictions placed here, then please report it as an issue. If +possible, we will create a way for you to implement your functionality without +exposing things that should not be exposed. + +=head1 DESCRIPTION + +This package exports all the functions necessary to write and/or verify testing +tools. Using these building blocks you can begin writing test tools very +quickly. You are also provided with tools that help you to test the tools you +write. + +=head1 SYNOPSIS + +=head2 WRITING A TOOL + +The C method is your primary interface into the Test2 framework. + + package My::Ok; + use Test2::API qw/context/; + + our @EXPORT = qw/my_ok/; + use base 'Exporter'; + + # Just like ok() from Test::More + sub my_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); # Get a context + $ctx->ok($bool, $name); + $ctx->release; # Release the context + return $bool; + } + +See L for a list of methods available on the context object. + +=head2 TESTING YOUR TOOLS + +The C tool lets you temporarily intercept all events +generated by the test system: + + use Test2::API qw/intercept/; + + use My::Ok qw/my_ok/; + + my $events = intercept { + # These events are not displayed + my_ok(1, "pass"); + my_ok(0, "fail"); + }; + + my_ok(@$events == 2, "got 2 events, the pass and the fail"); + my_ok($events->[0]->pass, "first event passed"); + my_ok(!$events->[1]->pass, "second event failed"); + +=head3 DEEP EVENT INTERCEPTION + +Normally C only intercepts events sent to the main hub (as +added by intercept itself). Nested hubs, such as those created by subtests, +will not be intercepted. This is normally what you will still see the nested +events by inspecting the subtest event. However there are times where you want +to verify each event as it is sent, in that case use C. + + my $events = intercept_Deep { + buffered_subtest foo => sub { + ok(1, "pass"); + }; + }; + +C<$events> in this case will contain 3 items: + +=over 4 + +=item The event from C + +=item The plan event for the subtest + +=item The subtest event itself, with the first 2 events nested inside it as children. + +=back + +This lets you see the order in which the events were sent, unlike +C which only lets you see events as the main hub sees them. + +=head2 OTHER API FUNCTIONS + + use Test2::API qw{ + test2_init_done + test2_stack + test2_set_is_end + test2_get_is_end + test2_ipc + test2_formatter_set + test2_formatter + test2_is_testing_done + }; + + my $init = test2_init_done(); + my $stack = test2_stack(); + my $ipc = test2_ipc(); + + test2_formatter_set($FORMATTER) + my $formatter = test2_formatter(); + + ... And others ... + +=head1 MAIN API EXPORTS + +All exports are optional. You must specify subs to import. + + use Test2::API qw/context intercept run_subtest/; + +This is the list of exports that are most commonly needed. If you are simply +writing a tool, then this is probably all you need. If you need something and +you cannot find it here, then you can also look at L. + +These exports lack the 'test2_' prefix because of how important/common they +are. Exports in the L section have the 'test2_' prefix to +ensure they stand out. + +=head2 context(...) + +Usage: + +=over 4 + +=item $ctx = context() + +=item $ctx = context(%params) + +=back + +The C function will always return the current context. If +there is already a context active, it will be returned. If there is not an +active context, one will be generated. When a context is generated it will +default to using the file and line number where the currently running sub was +called from. + +Please see L for important rules about +what you can and cannot do with a context once it is obtained. + +B This function will throw an exception if you ignore the context object +it returns. + +B On perls 5.14+ a depth check is used to insure there are no context +leaks. This cannot be safely done on older perls due to +L +You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or +C<$Test2::API::DO_DEPTH_CHECK = 1> B loading L. + +=head3 OPTIONAL PARAMETERS + +All parameters to C are optional. + +=over 4 + +=item level => $int + +If you must obtain a context in a sub deeper than your entry point you can use +this to tell it how many EXTRA stack frames to look back. If this option is not +provided the default of C<0> is used. + + sub third_party_tool { + my $sub = shift; + ... # Does not obtain a context + $sub->(); + ... + } + + third_party_tool(sub { + my $ctx = context(level => 1); + ... + $ctx->release; + }); + +=item wrapped => $int + +Use this if you need to write your own tool that wraps a call to C +with the intent that it should return a context object. + + sub my_context { + my %params = ( wrapped => 0, @_ ); + $params{wrapped}++; + my $ctx = context(%params); + ... + return $ctx; + } + + sub my_tool { + my $ctx = my_context(); + ... + $ctx->release; + } + +If you do not do this, then tools you call that also check for a context will +notice that the context they grabbed was created at the same stack depth, which +will trigger protective measures that warn you and destroy the existing +context. + +=item stack => $stack + +Normally C looks at the global hub stack. If you are maintaining +your own L instance you may pass it in to be used +instead of the global one. + +=item hub => $hub + +Use this parameter if you want to obtain the context for a specific hub instead +of whatever one happens to be at the top of the stack. + +=item on_init => sub { ... } + +This lets you provide a callback sub that will be called B if your call +to C generated a new context. The callback B be called if +C is returning an existing context. The only argument passed into +the callback will be the context object itself. + + sub foo { + my $ctx = context(on_init => sub { 'will run' }); + + my $inner = sub { + # This callback is not run since we are getting the existing + # context from our parent sub. + my $ctx = context(on_init => sub { 'will NOT run' }); + $ctx->release; + } + $inner->(); + + $ctx->release; + } + +=item on_release => sub { ... } + +This lets you provide a callback sub that will be called when the context +instance is released. This callback will be added to the returned context even +if an existing context is returned. If multiple calls to context add callbacks, +then all will be called in reverse order when the context is finally released. + + sub foo { + my $ctx = context(on_release => sub { 'will run second' }); + + my $inner = sub { + my $ctx = context(on_release => sub { 'will run first' }); + + # Neither callback runs on this release + $ctx->release; + } + $inner->(); + + # Both callbacks run here. + $ctx->release; + } + +=back + +=head2 release($;$) + +Usage: + +=over 4 + +=item release $ctx; + +=item release $ctx, ...; + +=back + +This is intended as a shortcut that lets you release your context and return a +value in one statement. This function will get your context, and an optional +return value. It will release your context, then return your value. Scalar +context is always assumed. + + sub tool { + my $ctx = context(); + ... + + return release $ctx, 1; + } + +This tool is most useful when you want to return the value you get from calling +a function that needs to see the current context: + + my $ctx = context(); + my $out = some_tool(...); + $ctx->release; + return $out; + +We can combine the last 3 lines of the above like so: + + my $ctx = context(); + release $ctx, some_tool(...); + +=head2 context_do(&;@) + +Usage: + + sub my_tool { + context_do { + my $ctx = shift; + + my (@args) = @_; + + $ctx->ok(1, "pass"); + + ... + + # No need to call $ctx->release, done for you on scope exit. + } @_; + } + +Using this inside your test tool takes care of a lot of boilerplate for you. It +will ensure a context is acquired. It will capture and rethrow any exception. It +will insure the context is released when you are done. It preserves the +subroutine call context (array, scalar, void). + +This is the safest way to write a test tool. The only two downsides to this are a +slight performance decrease, and some extra indentation in your source. If the +indentation is a problem for you then you can take a peek at the next section. + +=head2 no_context(&;$) + +Usage: + +=over 4 + +=item no_context { ... }; + +=item no_context { ... } $hid; + + sub my_tool(&) { + my $code = shift; + my $ctx = context(); + ... + + no_context { + # Things in here will not see our current context, they get a new + # one. + + $code->(); + }; + + ... + $ctx->release; + }; + +=back + +This tool will hide a context for the provided block of code. This means any +tools run inside the block will get a completely new context if they acquire +one. The new context will be inherited by tools nested below the one that +acquired it. + +This will normally hide the current context for the top hub. If you need to +hide the context for a different hub you can pass in the optional C<$hid> +parameter. + +=head2 intercept(&) + +Usage: + + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + ... + }; + +This function takes a codeblock as its only argument, and it has a prototype. +It will execute the codeblock, intercepting any generated events in the +process. It will return an array reference with all the generated event +objects. All events should be subclasses of L. + +This is a very low-level subtest tool. This is useful for writing tools which +produce subtests. This is not intended for people simply writing tests. + +=head2 run_subtest(...) + +Usage: + + run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) + + # or + + run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) + +This will run the provided codeblock with the args in C<@args>. This codeblock +will be run as a subtest. A subtest is an isolated test state that is condensed +into a single L event, which contains all events +generated inside the subtest. + +=head3 ARGUMENTS: + +=over 4 + +=item $NAME + +The name of the subtest. + +=item \&CODE + +The code to run inside the subtest. + +=item $BUFFERED or \%PARAMS + +If this is a simple scalar then it will be treated as a boolean for the +'buffered' setting. If this is a hash reference then it will be used as a +parameters hash. The param hash will be used for hub construction (with the +specified keys removed). + +Keys that are removed and used by run_subtest: + +=over 4 + +=item 'buffered' => $bool + +Toggle buffered status. + +=item 'inherit_trace' => $bool + +Normally the subtest hub is pushed and the sub is allowed to generate its own +root context for the hub. When this setting is turned on a root context will be +created for the hub that shares the same trace as the current context. + +Set this to true if your tool is producing subtests without user-specified +subs. + +=item 'no_fork' => $bool + +Defaults to off. Normally forking inside a subtest will actually fork the +subtest, resulting in 2 final subtest events. This parameter will turn off that +behavior, only the original process/thread will return a final subtest event. + +=back + +=item @ARGS + +Any extra arguments you want passed into the subtest code. + +=back + +=head3 BUFFERED VS UNBUFFERED (OR STREAMED) + +Normally all events inside and outside a subtest are sent to the formatter +immediately by the hub. Sometimes it is desirable to hold off sending events +within a subtest until the subtest is complete. This usually depends on the +formatter being used. + +=over 4 + +=item Things not effected by this flag + +In both cases events are generated and stored in an array. This array is +eventually used to populate the C attribute on the +L event that is generated at the end of the subtest. +This flag has no effect on this part, it always happens. + +At the end of the subtest, the final L event is sent to +the formatter. + +=item Things that are effected by this flag + +The C attribute of the L event will be set to +the value of this flag. This means any formatter, listener, etc which looks at +the event will know if it was buffered. + +=item Things that are formatter dependant + +Events within a buffered subtest may or may not be sent to the formatter as +they happen. If a formatter fails to specify then the default is to B +the events as they are generated, instead the formatter can pull them from the +C attribute. + +A formatter can specify by implementing the C method. If this +method returns true then events generated inside a buffered subtest will not be +sent independently of the final subtest event. + +=back + +An example of how this is used is the L formatter. For +unbuffered subtests the events are rendered as they are generated. At the end +of the subtest, the final subtest event is rendered, but the C +attribute is ignored. For buffered subtests the opposite occurs, the events are +NOT rendered as they are generated, instead the C attribute is used +to render them all at once. This is useful when running subtests tests in +parallel, since without it the output from subtests would be interleaved +together. + +=head1 OTHER API EXPORTS + +Exports in this section are not commonly needed. These all have the 'test2_' +prefix to help ensure they stand out. You should look at the L section before looking here. This section is one where "Great power +comes with great responsibility". It is possible to break things badly if you +are not careful with these. + +All exports are optional. You need to list which ones you want at import time: + + use Test2::API qw/test2_init_done .../; + +=head2 STATUS AND INITIALIZATION STATE + +These provide access to internal state and object instances. + +=over 4 + +=item $bool = test2_init_done() + +This will return true if the stack and IPC instances have already been +initialized. It will return false if they have not. Init happens as late as +possible. It happens as soon as a tool requests the IPC instance, the +formatter, or the stack. + +=item $bool = test2_load_done() + +This will simply return the boolean value of the loaded flag. If Test2 has +finished loading this will be true, otherwise false. Loading is considered +complete the first time a tool requests a context. + +=item test2_set_is_end() + +=item test2_set_is_end($bool) + +This is used to toggle Test2's belief that the END phase has already started. +With no arguments this will set it to true. With arguments it will set it to +the first argument's value. + +This is used to prevent the use of C in END blocks which can cause +segfaults. This is only necessary in some persistent environments that may have +multiple END phases. + +=item $bool = test2_get_is_end() + +Check if Test2 believes it is the END phase. + +=item $stack = test2_stack() + +This will return the global L instance. If this has not +yet been initialized it will be initialized now. + +=item $bool = test2_is_testing_done() + +This will return true if testing is complete and no other events should be +sent. This is useful in things like warning handlers where you might want to +turn warnings into events, but need them to start acting like normal warnings +when testing is done. + + $SIG{__WARN__} = sub { + my ($warning) = @_; + + if (test2_is_testing_done()) { + warn @_; + } + else { + my $ctx = context(); + ... + $ctx->release + } + } + +=item test2_ipc_disable + +Disable IPC. + +=item $bool = test2_ipc_diabled + +Check if IPC is disabled. + +=item test2_ipc_wait_enable() + +=item test2_ipc_wait_disable() + +=item $bool = test2_ipc_wait_enabled() + +These can be used to turn IPC waiting on and off, or check the current value of +the flag. + +Waiting is turned on by default. Waiting will cause the parent process/thread +to wait until all child processes and threads are finished before exiting. You +will almost never want to turn this off. + +=item $bool = test2_no_wait() + +=item test2_no_wait($bool) + +B: This is a confusing interface, it is better to use +C, C and +C. + +This can be used to get/set the no_wait status. Waiting is turned on by +default. Waiting will cause the parent process/thread to wait until all child +processes and threads are finished before exiting. You will almost never want +to turn this off. + +=item $fh = test2_stdout() + +=item $fh = test2_stderr() + +These functions return the filehandles that test output should be written to. +They are primarily useful when writing a custom formatter and code that turns +events into actual output (TAP, etc.). They will return a dupe of the original +filehandles that formatted output can be sent to regardless of whatever state +the currently running test may have left STDOUT and STDERR in. + +=item test2_reset_io() + +Re-dupe the internal filehandles returned by C and +C from the current STDOUT and STDERR. You shouldn't need to do +this except in very peculiar situations (for example, you're testing a new +formatter and you need control over where the formatter is sending its output.) + +=back + +=head2 BEHAVIOR HOOKS + +These are hooks that allow you to add custom behavior to actions taken by Test2 +and tools built on top of it. + +=over 4 + +=item test2_add_callback_exit(sub { ... }) + +This can be used to add a callback that is called after all testing is done. This +is too late to add additional results, the main use of this callback is to set the +exit code. + + test2_add_callback_exit( + sub { + my ($context, $exit, \$new_exit) = @_; + ... + } + ); + +The C<$context> passed in will be an instance of L. The +C<$exit> argument will be the original exit code before anything modified it. +C<$$new_exit> is a reference to the new exit code. You may modify this to +change the exit code. Please note that C<$$new_exit> may already be different +from C<$exit> + +=item test2_add_callback_post_load(sub { ... }) + +Add a callback that will be called when Test2 is finished loading. This +means the callback will be run once, the first time a context is obtained. +If Test2 has already finished loading then the callback will be run immediately. + +=item test2_add_callback_testing_done(sub { ... }) + +This adds your coderef as a follow-up to the root hub after Test2 is finished loading. + +This is essentially a helper to do the following: + + test2_add_callback_post_load(sub { + my $stack = test2_stack(); + $stack->top; # Insure we have a hub + my ($hub) = Test2::API::test2_stack->all; + + $hub->set_active(1); + + $hub->follow_up(sub { ... }); # <-- Your coderef here + }); + +=item test2_add_callback_context_acquire(sub { ... }) + +Add a callback that will be called every time someone tries to acquire a +context. This will be called on EVERY call to C. It gets a single +argument, a reference to the hash of parameters being used the construct the +context. This is your chance to change the parameters by directly altering the +hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +=item test2_add_callback_context_init(sub { ... }) + +Add a callback that will be called every time a new context is created. The +callback will receive the newly created context as its only argument. + +=item test2_add_callback_context_release(sub { ... }) + +Add a callback that will be called every time a context is released. The +callback will receive the released context as its only argument. + +=item test2_add_callback_pre_subtest(sub { ... }) + +Add a callback that will be called every time a subtest is going to be +run. The callback will receive the subtest name, coderef, and any +arguments. + +=item @list = test2_list_context_acquire_callbacks() + +Return all the context acquire callback references. + +=item @list = test2_list_context_init_callbacks() + +Returns all the context init callback references. + +=item @list = test2_list_context_release_callbacks() + +Returns all the context release callback references. + +=item @list = test2_list_exit_callbacks() + +Returns all the exit callback references. + +=item @list = test2_list_post_load_callbacks() + +Returns all the post load callback references. + +=item @list = test2_list_pre_subtest_callbacks() + +Returns all the pre-subtest callback references. + +=item test2_add_uuid_via(sub { ... }) + +=item $sub = test2_add_uuid_via() + +This allows you to provide a UUID generator. If provided UUIDs will be attached +to all events, hubs, and contexts. This is useful for storing, tracking, and +linking these objects. + +The sub you provide should always return a unique identifier. Most things will +expect a proper UUID string, however nothing in Test2::API enforces this. + +The sub will receive exactly 1 argument, the type of thing being tagged +'context', 'hub', or 'event'. In the future additional things may be tagged, in +which case new strings will be passed in. These are purely informative, you can +(and usually should) ignore them. + +=back + +=head2 IPC AND CONCURRENCY + +These let you access, or specify, the IPC system internals. + +=over 4 + +=item $bool = test2_has_ipc() + +Check if IPC is enabled. + +=item $ipc = test2_ipc() + +This will return the global L instance. If this has not yet +been initialized it will be initialized now. + +=item test2_ipc_add_driver($DRIVER) + +Add an IPC driver to the list. This will add the driver to the start of the +list. + +=item @drivers = test2_ipc_drivers() + +Get the list of IPC drivers. + +=item $bool = test2_ipc_polling() + +Check if polling is enabled. + +=item test2_ipc_enable_polling() + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item test2_ipc_disable_polling() + +Turn off IPC polling. + +=item test2_ipc_enable_shm() + +Legacy, this is currently a no-op that returns 0; + +=item test2_ipc_set_pending($uniq_val) + +Tell other processes and events that an event is pending. C<$uniq_val> should +be a unique value no other thread/process will generate. + +B After calling this C will return 1. This is +intentional, and not avoidable. + +=item $pending = test2_ipc_get_pending() + +This returns -1 if there is no way to check (assume yes) + +This returns 0 if there are (most likely) no pending events. + +This returns 1 if there are (likely) pending events. Upon return it will reset, +nothing else will be able to see that there were pending events. + +=item $timeout = test2_ipc_get_timeout() + +=item test2_ipc_set_timeout($timeout) + +Get/Set the timeout value for the IPC system. This timeout is how long the IPC +system will wait for child processes and threads to finish before aborting. + +The default value is C<30> seconds. + +=back + +=head2 MANAGING FORMATTERS + +These let you access, or specify, the formatters that can/should be used. + +=over 4 + +=item $formatter = test2_formatter + +This will return the global formatter class. This is not an instance. By +default the formatter is set to L. + +You can override this default using the C environment variable. + +Normally 'Test2::Formatter::' is prefixed to the value in the +environment variable: + + $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter + $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter + +If you want to specify a full module name you use the '+' prefix: + + $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter + +=item test2_formatter_set($class_or_instance) + +Set the global formatter class. This can only be set once. B This will +override anything specified in the 'T2_FORMATTER' environment variable. + +=item @formatters = test2_formatters() + +Get a list of all loaded formatters. + +=item test2_formatter_add($class_or_instance) + +Add a formatter to the list. Last formatter added is used at initialization. If +this is called after initialization a warning will be issued. + +=back + +=head1 OTHER EXAMPLES + +See the C directory included in this distribution. + +=head1 SEE ALSO + +L - Detailed documentation of the context object. + +L - The IPC system used for threading/fork support. + +L - Formatters such as TAP live here. + +L - Events live in this namespace. + +L - All events eventually funnel through a hub. Custom hubs are how +C and C are implemented. + +=head1 MAGIC + +This package has an END block. This END block is responsible for setting the +exit code based on the test results. This end block also calls the callbacks that +can be added to this package. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Bail.pm ddclient-3.10.0/t/lib/Test2/Event/Bail.pm --- ddclient-3.9.1/t/lib/Test2/Event/Bail.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Bail.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,109 @@ +package Test2::Event::Bail; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{reason buffered}; + +# Make sure the tests terminate +sub terminate { 255 }; + +sub global { 1 }; + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + return "Bail out! " . $self->{+REASON} + if $self->{+REASON}; + + return "Bail out!"; +} + +sub diagnostics { 1 } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{control} = { + global => 1, + halt => 1, + details => $self->{+REASON}, + terminate => 255, + }; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Bail - Bailout! + +=head1 DESCRIPTION + +The bailout event is generated when things go horribly wrong and you need to +halt all testing in the current file. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Bail; + + my $ctx = context(); + my $event = $ctx->bail('Stuff is broken'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $reason = $e->reason + +The reason for the bailout. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Diag.pm ddclient-3.10.0/t/lib/Test2/Event/Diag.pm --- ddclient-3.9.1/t/lib/Test2/Event/Diag.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Diag.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,99 @@ +package Test2::Event::Diag; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +sub diagnostics { 1 } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Diag - Diag event type + +=head1 DESCRIPTION + +Diagnostics messages, typically rendered to STDERR. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Diag; + + my $ctx = context(); + my $event = $ctx->diag($message); + +=head1 ACCESSORS + +=over 4 + +=item $diag->message + +The message for the diag. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Encoding.pm ddclient-3.10.0/t/lib/Test2/Event/Encoding.pm --- ddclient-3.9.1/t/lib/Test2/Event/Encoding.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Encoding.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,97 @@ +package Test2::Event::Encoding; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/encoding/; + +sub init { + my $self = shift; + defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; +} + +sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + $out->{control}->{encoding} = $self->{+ENCODING}; + $out->{about}->{details} = $self->summary; + return $out; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Encoding - Set the encoding for the output stream + +=head1 DESCRIPTION + +The encoding event is generated when a test file wants to specify the encoding +to be used when formatting its output. This event is intended to be produced +by formatter classes and used for interpreting test names, message contents, +etc. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $encoding = $e->encoding + +The encoding being specified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Exception.pm ddclient-3.10.0/t/lib/Test2/Event/Exception.pm --- ddclient-3.9.1/t/lib/Test2/Event/Exception.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Exception.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,113 @@ +package Test2::Event::Exception; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{error}; + +sub init { + my $self = shift; + $self->{+ERROR} = "$self->{+ERROR}"; +} + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + chomp(my $msg = "Exception: " . $self->{+ERROR}); + return $msg; +} + +sub diagnostics { 1 } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{errors} = [ + { + tag => 'ERROR', + fail => 1, + details => $self->{+ERROR}, + } + ]; + + return $out; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Exception - Exception event + +=head1 DESCRIPTION + +An exception event will display to STDERR, and will prevent the overall test +file from passing. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Exception; + + my $ctx = context(); + my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $reason = $e->error + +The reason for the exception. + +=back + +=head1 CAVEATS + +Be aware that all exceptions are stringified during construction. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Fail.pm ddclient-3.10.0/t/lib/Test2/Event/Fail.pm --- ddclient-3.9.1/t/lib/Test2/Event/Fail.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Fail.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,118 @@ +package Test2::Event::Fail; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############# +# Old API +sub summary { "fail" } +sub increments_count { 1 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub causes_fail { + my $self = shift; + return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; + return 1; +} + +############# +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'fail'; + + $out->{assert} = {pass => 0, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Fail - Event for a simple failed assertion + +=head1 DESCRIPTION + +This is an optimal representation of a failed assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub fail { + my ($name) = @_; + my $ctx = context(); + $ctx->fail($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Generic.pm ddclient-3.10.0/t/lib/Test2/Event/Generic.pm --- ddclient-3.9.1/t/lib/Test2/Event/Generic.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Generic.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,280 @@ +package Test2::Event::Generic; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; + +my @FIELDS = qw{ + causes_fail increments_count diagnostics no_display callback terminate + global sets_plan summary facet_data +}; +my %DEFAULTS = ( + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, +); + +sub init { + my $self = shift; + + for my $field (@FIELDS) { + my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; + next unless defined $val; + + my $set = "set_$field"; + $self->$set($val); + } +} + +for my $field (@FIELDS) { + no strict 'refs'; + + *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } + unless exists &{$field}; + + *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } + unless exists &{"set_$field"}; +} + +sub can { + my $self = shift; + my ($name) = @_; + return $self->SUPER::can($name) unless $name eq 'callback'; + return $self->{callback} || \&Test2::Event::callback; +} + +sub facet_data { + my $self = shift; + return $self->{facet_data} || $self->SUPER::facet_data(); +} + +sub summary { + my $self = shift; + return $self->{summary} if defined $self->{summary}; + $self->SUPER::summary(); +} + +sub sets_plan { + my $self = shift; + return unless $self->{sets_plan}; + return @{$self->{sets_plan}}; +} + +sub callback { + my $self = shift; + my $cb = $self->{callback} || return; + $self->$cb(@_); +} + +sub set_global { + my $self = shift; + my ($bool) = @_; + + if(!defined $bool) { + delete $self->{global}; + return undef; + } + + $self->{global} = $bool; +} + +sub set_callback { + my $self = shift; + my ($cb) = @_; + + if(!defined $cb) { + delete $self->{callback}; + return undef; + } + + croak "callback must be a code reference" + unless ref($cb) && reftype($cb) eq 'CODE'; + + $self->{callback} = $cb; +} + +sub set_terminate { + my $self = shift; + my ($exit) = @_; + + if(!defined $exit) { + delete $self->{terminate}; + return undef; + } + + croak "terminate must be a positive integer" + unless $exit =~ m/^\d+$/; + + $self->{terminate} = $exit; +} + +sub set_sets_plan { + my $self = shift; + my ($plan) = @_; + + if(!defined $plan) { + delete $self->{sets_plan}; + return undef; + } + + croak "'sets_plan' must be an array reference" + unless ref($plan) && reftype($plan) eq 'ARRAY'; + + $self->{sets_plan} = $plan; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Generic - Generic event type. + +=head1 DESCRIPTION + +This is a generic event that lets you customize all fields in the event API. +This is useful if you have need for a custom event that does not make sense as +a published reusable event subclass. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub send_custom_fail { + my $ctx = shift; + + $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); + + $ctx->release; + } + + send_custom_fail(); + +=head1 METHODS + +=over 4 + +=item $e->facet_data($data) + +=item $data = $e->facet_data + +Get or set the facet data (see L). If no facet_data is set then +C<< Test2::Event->facet_data >> will be called to produce facets from the other +data. + +=item $e->callback($hub) + +Call the custom callback if one is set, otherwise this does nothing. + +=item $e->set_callback(sub { ... }) + +Set the custom callback. The custom callback must be a coderef. The first +argument to your callback will be the event itself, the second will be the +L that is using the callback. + +=item $bool = $e->causes_fail + +=item $e->set_causes_fail($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->diagnostics + +=item $e->set_diagnostics($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool_or_undef = $e->global + +=item @bool_or_empty = $e->global + +=item $e->set_global($bool_or_undef) + +Get/Set the C attribute. This defaults to an empty list which is +undef in scalar context. + +=item $bool = $e->increments_count + +=item $e->set_increments_count($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->no_display + +=item $e->set_no_display($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item @plan = $e->sets_plan + +Get the plan if this event sets one. The plan is a list of up to 3 items: +C<($count, $directive, $reason)>. C<$count> must be defined, the others may be +undef, or may not exist at all. + +=item $e->set_sets_plan(\@plan) + +Set the plan. You must pass in an arrayref with up to 3 elements. + +=item $summary = $e->summary + +=item $e->set_summary($summary_or_undef) + +Get/Set the summary. This will default to the event package +C<'Test2::Event::Generic'>. You can set it to any value. Setting this to +C will reset it to the default. + +=item $int_or_undef = $e->terminate + +=item @int_or_empty = $e->terminate + +=item $e->set_terminate($int_or_undef) + +This will get/set the C attribute. This defaults to undef in scalar +context, or an empty list in list context. Setting this to undef will clear it +completely. This must be set to a positive integer (0 or larger). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Note.pm ddclient-3.10.0/t/lib/Test2/Event/Note.pm --- ddclient-3.9.1/t/lib/Test2/Event/Note.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Note.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,97 @@ +package Test2::Event::Note; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'NOTE', + debug => 0, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Note - Note event type + +=head1 DESCRIPTION + +Notes, typically rendered to STDOUT. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Note; + + my $ctx = context(); + my $event = $ctx->Note($message); + +=head1 ACCESSORS + +=over 4 + +=item $note->message + +The message for the note. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Ok.pm ddclient-3.10.0/t/lib/Test2/Event/Ok.pm --- ddclient-3.9.1/t/lib/Test2/Event/Ok.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Ok.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,162 @@ +package Test2::Event::Ok; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{ + pass effective_pass name todo +}; + +sub init { + my $self = shift; + + # Do not store objects here, only true or false + $self->{+PASS} = $self->{+PASS} ? 1 : 0; + $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); +} + +{ + no warnings 'redefine'; + sub set_todo { + my $self = shift; + my ($todo) = @_; + $self->{+TODO} = $todo; + $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; + } +} + +sub increments_count { 1 }; + +sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Assertion"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)" + } + + return $name; +} + +sub extra_amnesty { + my $self = shift; + return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); + return { + tag => 'TODO', + details => $self->{+TODO}, + }; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->{+PASS}, + details => $self->{+NAME}, + }; + + if (my @exra_amnesty = $self->extra_amnesty) { + unshift @{$out->{amnesty}} => @exra_amnesty; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Ok - Ok event type + +=head1 DESCRIPTION + +Ok events are generated whenever you run a test that produces a result. +Examples are C, and C. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Ok; + + my $ctx = context(); + my $event = $ctx->ok($bool, $name, \@diag); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Ok', + pass => $bool, + name => $name, + ); + +=head1 ACCESSORS + +=over 4 + +=item $rb = $e->pass + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=item $name = $e->name + +Name of the test. + +=item $b = $e->effective_pass + +This is the true/false value of the test after TODO and similar modifiers are +taken into account. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Pass.pm ddclient-3.10.0/t/lib/Test2/Event/Pass.pm --- ddclient-3.9.1/t/lib/Test2/Event/Pass.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Pass.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,114 @@ +package Test2::Event::Pass; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############## +# Old API +sub summary { "pass" } +sub increments_count { 1 } +sub causes_fail { 0 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +############## +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'pass'; + + $out->{assert} = {pass => 1, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Pass - Event for a simple passing assertion + +=head1 DESCRIPTION + +This is an optimal representation of a passing assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub pass { + my ($name) = @_; + my $ctx = context(); + $ctx->pass($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Plan.pm ddclient-3.10.0/t/lib/Test2/Event/Plan.pm --- ddclient-3.9.1/t/lib/Test2/Event/Plan.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Plan.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,169 @@ +package Test2::Event::Plan; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{max directive reason}; + +use Carp qw/confess/; + +my %ALLOWED = ( + 'SKIP' => 1, + 'NO PLAN' => 1, +); + +sub init { + if ($_[0]->{+DIRECTIVE}) { + $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; + $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; + + confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" + unless $ALLOWED{$_[0]->{+DIRECTIVE}}; + } + else { + confess "Cannot have a reason without a directive!" + if defined $_[0]->{+REASON}; + + confess "No number of tests specified" + unless defined $_[0]->{+MAX}; + + confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" + unless $_[0]->{+MAX} =~ m/^\d+$/; + + $_[0]->{+DIRECTIVE} = ''; + } +} + +sub sets_plan { + my $self = shift; + return ( + $self->{+MAX}, + $self->{+DIRECTIVE}, + $self->{+REASON}, + ); +} + +sub terminate { + my $self = shift; + # On skip_all we want to terminate the hub + return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; + return undef; +} + +sub summary { + my $self = shift; + my $max = $self->{+MAX}; + my $directive = $self->{+DIRECTIVE}; + my $reason = $self->{+REASON}; + + return "Plan is $max assertions" + if $max || !$directive; + + return "Plan is '$directive', $reason" + if $reason; + + return "Plan is '$directive'"; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef + unless defined $out->{control}->{terminate}; + + $out->{plan} = {count => $self->{+MAX}}; + $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; + + if (my $dir = $self->{+DIRECTIVE}) { + $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; + $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; + } + + return $out; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Plan - The event of a plan + +=head1 DESCRIPTION + +Plan events are fired off whenever a plan is declared, done testing is called, +or a subtext completes. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Plan; + + my $ctx = context(); + + # Plan for 10 tests to run + my $event = $ctx->plan(10); + + # Plan to skip all tests (will exit 0) + $ctx->plan(0, skip_all => "These tests need to be skipped"); + +=head1 ACCESSORS + +=over 4 + +=item $num = $plan->max + +Get the number of expected tests + +=item $dir = $plan->directive + +Get the directive (such as TODO, skip_all, or no_plan). + +=item $reason = $plan->reason + +Get the reason for the directive. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Skip.pm ddclient-3.10.0/t/lib/Test2/Event/Skip.pm --- ddclient-3.9.1/t/lib/Test2/Event/Skip.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Skip.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,127 @@ +package Test2::Event::Skip; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{reason}; + +sub init { + my $self = shift; + $self->SUPER::init; + $self->{+EFFECTIVE_PASS} = 1; +} + +sub causes_fail { 0 } + +sub summary { + my $self = shift; + my $out = $self->SUPER::summary(@_); + + if (my $reason = $self->reason) { + $out .= " (SKIP: $reason)"; + } + else { + $out .= " (SKIP)"; + } + + return $out; +} + +sub extra_amnesty { + my $self = shift; + + my @out; + + push @out => { + tag => 'TODO', + details => $self->{+TODO}, + } if defined $self->{+TODO}; + + push @out => { + tag => 'skip', + details => $self->{+REASON}, + inherited => 0, + }; + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Skip - Skip event type + +=head1 DESCRIPTION + +Skip events bump test counts just like L events, but +they can never fail. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Skip; + + my $ctx = context(); + my $event = $ctx->skip($name, $reason); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Skip', + name => $name, + reason => $reason, + ); + +=head1 ACCESSORS + +=over 4 + +=item $reason = $e->reason + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Subtest.pm ddclient-3.10.0/t/lib/Test2/Event/Subtest.pm --- ddclient-3.9.1/t/lib/Test2/Event/Subtest.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Subtest.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,160 @@ +package Test2::Event::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid}; + +sub init { + my $self = shift; + $self->SUPER::init(); + $self->{+SUBEVENTS} ||= []; + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } +} + +{ + no warnings 'redefine'; + + sub set_subevents { + my $self = shift; + my @subevents = @_; + + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; + } + + $self->{+SUBEVENTS} = \@subevents; + } + + sub set_effective_pass { + my $self = shift; + my ($pass) = @_; + + if ($pass) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } + elsif ($self->{+EFFECTIVE_PASS} && !$pass) { + for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { + $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; + } + } + + $self->{+EFFECTIVE_PASS} = $pass; + } +} + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Subtest"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)"; + } + + return $name; +} + +sub facet_data { + my $self = shift; + + my $out = $self->SUPER::facet_data(); + + $out->{parent} = { + hid => $self->subtest_id, + children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], + buffered => $self->{+BUFFERED}, + }; + + return $out; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); + + push @{$self->{+AMNESTY}} => $am; + + for my $e (@{$self->{+SUBEVENTS}}) { + $e->add_amnesty($am->clone(inherited => 1)); + } + } +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Subtest - Event for subtest types + +=head1 DESCRIPTION + +This class represents a subtest. This class is a subclass of +L. + +=head1 ACCESSORS + +This class inherits from L. + +=over 4 + +=item $arrayref = $e->subevents + +Returns the arrayref containing all the events from the subtest + +=item $bool = $e->buffered + +True if the subtest is buffered, that is all subevents render at once. If this +is false it means all subevents render as they are produced. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/TAP/Version.pm ddclient-3.10.0/t/lib/Test2/Event/TAP/Version.pm --- ddclient-3.9.1/t/lib/Test2/Event/TAP/Version.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/TAP/Version.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,101 @@ +package Test2::Event::TAP::Version; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/version/; + +sub init { + my $self = shift; + defined $self->{+VERSION} or croak "'version' is a required attribute"; +} + +sub summary { 'TAP version ' . $_[0]->{+VERSION} } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::TAP::Version - Event for TAP version. + +=head1 DESCRIPTION + +This event is used if a TAP formatter wishes to set a version. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('TAP::Version', version => 42); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $version = $e->version + +The TAP version being parsed. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/V2.pm ddclient-3.10.0/t/lib/Test2/Event/V2.pm --- ddclient-3.9.1/t/lib/Test2/Event/V2.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/V2.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,238 @@ +package Test2::Event::V2; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Scalar::Util qw/reftype/; +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } + +use Test2::Util::Facets2Legacy qw{ + causes_fail diagnostics global increments_count no_display sets_plan + subtest_id summary terminate +}; + +use Test2::Util::HashBase qw/-about/; + +sub non_facet_keys { + return ( + +UUID, + Test2::Util::ExternalMeta::META_KEY(), + ); +} + +sub init { + my $self = shift; + + my $uuid; + if ($uuid = $self->{+UUID}) { + croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet" + if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid; + + $self->{+ABOUT}->{uuid} = $uuid; + } + elsif ($uuid = $self->{+ABOUT}->{uuid}) { + $self->SUPER::set_uuid($uuid); + } + + # Clone the trace, make sure it is blessed + if (my $trace = $self->{+TRACE}) { + $self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace); + } +} + +sub set_uuid { + my $self = shift; + my ($uuid) = @_; + $self->{+ABOUT}->{uuid} = $uuid; + $self->SUPER::set_uuid($uuid); +} + +sub facet_data { + my $self = shift; + my $f = { %{$self} }; + + delete $f->{$_} for $self->non_facet_keys; + + my %out; + for my $k (keys %$f) { + next if substr($k, 0, 1) eq '_'; + + my $data = $f->{$k} or next; # Key is there, but no facet + my $is_list = 'ARRAY' eq (reftype($data) || ''); + $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data}; + } + + if (my $meta = $self->meta_facet_data) { + $out{meta} = {%$meta, %{$out{meta} || {}}}; + } + + return \%out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::V2 - Second generation event. + +=head1 DESCRIPTION + +This is the event type that should be used instead of L or its +legacy subclasses. + +=head1 SYNOPSIS + +=head2 USING A CONTEXT + + use Test2::API qw/context/; + + sub my_tool { + my $ctx = context(); + + my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]); + + $ctx->release; + + return $event; + } + +=head2 USING THE CONSTRUCTOR + + use Test2::Event::V2; + + my $e = Test2::Event::V2->new( + trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]}, + info => [{tag => 'NOTE', details => "This is a note"}], + ); + +=head1 METHODS + +This class inherits from L. + +=over 4 + +=item $fd = $e->facet_data() + +This will return a hashref of facet data. Each facet hash will be a shallow +copy of the original. + +=item $about = $e->about() + +This will return the 'about' facet hashref. + +B This will return the internal hashref, not a copy. + +=item $trace = $e->trace() + +This will return the 'trace' facet, normally blessed (but this is not enforced +when the trace is set using C. + +B This will return the internal trace, not a copy. + +=back + +=head2 MUTATION + +=over 4 + +=item $e->add_amnesty({...}) + +Inherited from L. This can be used to add 'amnesty' facets to an +existing event. Each new item is added to the B of the list. + +B Items B blessed when added. + +=item $e->add_hub({...}) + +Inherited from L. This is used by hubs to stamp events as they +pass through. New items are added to the B of the list. + +B Items B blessed when added. + +=item $e->set_uuid($UUID) + +Inherited from L, overridden to also vivify/mutate the 'about' +facet. + +=item $e->set_trace($trace) + +Inherited from L which allows you to change the trace. + +B This method does not bless/clone the trace for you. Many things will +expect the trace to be blessed, so you should probably do that. + +=back + +=head2 LEGACY SUPPORT METHODS + +These are all imported from L, see that module or +L for documentation on what they do. + +=over 4 + +=item causes_fail + +=item diagnostics + +=item global + +=item increments_count + +=item no_display + +=item sets_plan + +=item subtest_id + +=item summary + +=item terminate + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event/Waiting.pm ddclient-3.10.0/t/lib/Test2/Event/Waiting.pm --- ddclient-3.9.1/t/lib/Test2/Event/Waiting.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event/Waiting.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,76 @@ +package Test2::Event::Waiting; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; + +sub global { 1 }; + +sub summary { "IPC is waiting for children to finish..." } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Waiting - Tell all procs/threads it is time to be done + +=head1 DESCRIPTION + +This event has no data of its own. This event is sent out by the IPC system +when the main process/thread is ready to end. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/About.pm ddclient-3.10.0/t/lib/Test2/EventFacet/About.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/About.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/About.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,92 @@ +package Test2::EventFacet::About; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::About - Facet with event details. + +=head1 DESCRIPTION + +This facet has information about the event, such as event package. + +=head1 FIELDS + +=over 4 + +=item $string = $about->{details} + +=item $string = $about->details() + +Summary about the event. + +=item $package = $about->{package} + +=item $package = $about->package() + +Event package name. + +=item $bool = $about->{no_display} + +=item $bool = $about->no_display() + +True if the event should be skipped by formatters. + +=item $uuid = $about->{uuid} + +=item $uuid = $about->uuid() + +Will be set to a uuid if uuid tagging was enabled. + +=item $uuid = $about->{eid} + +=item $uuid = $about->eid() + +A unique (for the test job) identifier for the event. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Amnesty.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Amnesty.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Amnesty.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Amnesty.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,91 @@ +package Test2::EventFacet::Amnesty; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -inherited }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Amnesty - Facet for assertion amnesty. + +=head1 DESCRIPTION + +This package represents what is expected in units of amnesty. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string = $amnesty->{details} + +=item $string = $amnesty->details() + +Human readable explanation of why amnesty was granted. + +Example: I + +=item $short_string = $amnesty->{tag} + +=item $short_string = $amnesty->tag() + +Short string (usually 10 characters or less, not enforced, but may be truncated +by renderers) categorizing the amnesty. + +=item $bool = $amnesty->{inherited} + +=item $bool = $amnesty->inherited() + +This will be true if the amnesty was granted to a parent event and inherited by +this event, which is a child, such as an assertion within a subtest that is +marked todo. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Assert.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Assert.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Assert.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Assert.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,93 @@ +package Test2::EventFacet::Assert; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -pass -no_debug -number }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Assert - Facet representing an assertion. + +=head1 DESCRIPTION + +The assertion facet is provided by any event representing an assertion that was +made. + +=head1 FIELDS + +=over 4 + +=item $string = $assert->{details} + +=item $string = $assert->details() + +Human readable description of the assertion. + +=item $bool = $assert->{pass} + +=item $bool = $assert->pass() + +True if the assertion passed. + +=item $bool = $assert->{no_debug} + +=item $bool = $assert->no_debug() + +Set this to true if you have provided custom diagnostics and do not want the +defaults to be displayed. + +=item $int = $assert->{number} + +=item $int = $assert->number() + +(Optional) assertion number. This may be omitted or ignored. This is usually +only useful when parsing/processing TAP. + +B: This is not set by the Test2 system, assertion number is not known +until AFTER the assertion has been processed. This attribute is part of the +spec only for harnesses. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Control.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Control.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Control.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Control.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,107 @@ +package Test2::EventFacet::Control; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Control - Facet for hub actions and behaviors. + +=head1 DESCRIPTION + +This facet is used when the event needs to give instructions to the Test2 +internals. + +=head1 FIELDS + +=over 4 + +=item $string = $control->{details} + +=item $string = $control->details() + +Human readable explanation for the special behavior. + +=item $bool = $control->{global} + +=item $bool = $control->global() + +True if the event is global in nature and should be seen by all hubs. + +=item $exit = $control->{terminate} + +=item $exit = $control->terminate() + +Defined if the test should immediately exit, the value is the exit code and may +be C<0>. + +=item $bool = $control->{halt} + +=item $bool = $control->halt() + +True if all testing should be halted immediately. + +=item $bool = $control->{has_callback} + +=item $bool = $control->has_callback() + +True if the C method on the event should be called. + +=item $encoding = $control->{encoding} + +=item $encoding = $control->encoding() + +This can be used to change the encoding from this event onward. + +=item $phase = $control->{phase} + +=item $phase = $control->phase() + +Used to signal that a phase change has occurred. Currently only the perl END +phase is signaled. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Error.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Error.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Error.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Error.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,93 @@ +package Test2::EventFacet::Error; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +sub facet_key { 'errors' } +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -fail }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Error - Facet for errors that need to be shown. + +=head1 DESCRIPTION + +This facet is used when an event needs to convey errors. + +=head1 NOTES + +This facet has the hash key C<'errors'>, and is a list of facets instead of a +single item. + +=head1 FIELDS + +=over 4 + +=item $string = $error->{details} + +=item $string = $error->details() + +Explanation of the error, or the error itself (such as an exception). In perl +exceptions may be blessed objects, so this field may contain a blessed object. + +=item $short_string = $error->{tag} + +=item $short_string = $error->tag() + +Short tag to categorize the error. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $error->{fail} + +=item $bool = $error->fail() + +Not all errors are fatal, some are displayed having already been handled. Set +this to true if you want the error to cause the test to fail. Without this the +error is simply a diagnostics message that has no effect on the overall +pass/fail result. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Hub.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Hub.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Hub.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Hub.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,109 @@ +package Test2::EventFacet::Hub; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +sub is_list { 1 } +sub facet_key { 'hubs' } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Hub - Facet for the hubs an event passes through. + +=head1 DESCRIPTION + +These are a record of the hubs an event passes through. Most recent hub is the +first one in the list. + +=head1 FACET FIELDS + +=over 4 + +=item $string = $trace->{details} + +=item $string = $trace->details() + +The hub class or subclass + +=item $int = $trace->{pid} + +=item $int = $trace->pid() + +PID of the hub this event was sent to. + +=item $int = $trace->{tid} + +=item $int = $trace->tid() + +The thread ID of the hub the event was sent to. + +=item $hid = $trace->{hid} + +=item $hid = $trace->hid() + +The ID of the hub that the event was send to. + +=item $huuid = $trace->{huuid} + +=item $huuid = $trace->huuid() + +The UUID of the hub that the event was sent to. + +=item $int = $trace->{nested} + +=item $int = $trace->nested() + +How deeply nested the hub was. + +=item $bool = $trace->{buffered} + +=item $bool = $trace->buffered() + +True if the event was buffered and not sent to the formatter independent of a +parent (This should never be set when nested is C<0> or C). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Info/Table.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Info/Table.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Info/Table.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Info/Table.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,144 @@ +package Test2::EventFacet::Info::Table; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Carp qw/confess/; + +use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string}; + +sub init { + my $self = shift; + + confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}}; + + $self->{+AS_STRING} ||= ''; +} + +sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out } + +sub info_args { + my $self = shift; + + my $hash = $self->as_hash; + my $desc = $self->as_string; + + return (table => $hash, details => $desc); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Info::Table - Intermediary representation of a table. + +=head1 DESCRIPTION + +Intermediary representation of a table for use in specialized +L methods which generate L facets. + +=head1 SYNOPSIS + + use Test2::EventFacet::Info::Table; + use Test2::API qw/context/; + + sub my_tool { + my $ctx = context(); + + ... + + $ctx->fail( + $name, + "failure diag message", + Test2::EventFacet::Info::Table->new( + # Required + rows => [['a', 'b'], ['c', 'd'], ...], + + # Strongly Recommended + as_string => "... string to print when table cannot be rendered ...", + + # Optional + header => ['col1', 'col2'], + collapse => $bool, + no_collapse => ['col1', ...], + ), + ); + + ... + + $ctx->release; + } + + my_tool(); + +=head1 ATTRIBUTES + +=over 4 + +=item $header_aref = $t->header() + +=item $rows_aref = $t->rows() + +=item $bool = $t->collapse() + +=item $aref = $t->no_collapse() + +The above are all directly tied to the table hashref structure described in +L. + +=item $str = $t->as_string() + +This returns the string form of the table if it was set, otherwise it returns +the string C<< "
" >>. + +=item $href = $t->as_hash() + +This returns the data structure used for tables by L. + +=item %args = $t->info_args() + +This returns the arguments that should be used to construct the proper +L structure. + + return (table => $t->as_hash(), details => $t->as_string()); + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Info.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Info.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Info.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Info.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,132 @@ +package Test2::EventFacet::Info; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{-tag -debug -important -table}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Info - Facet for information a developer might care about. + +=head1 DESCRIPTION + +This facet represents messages intended for humans that will help them either +understand a result, or diagnose a failure. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string_or_structure = $info->{details} + +=item $string_or_structure = $info->details() + +Human readable string or data structure, this is the information to display. +Formatters are free to render the structures however they please. This may +contain a blessed object. + +If the C
attribute (see below) is set then a renderer may choose to +display the table instead of the details. + +=item $structure = $info->{table} + +=item $structure = $info->table() + +If the data the C facet needs to convey can be represented as a table +then the data may be placed in this attribute in a more raw form for better +display. The data must also be represented in the C
attribute for +renderers which do not support rendering tables directly. + +The table structure: + + my %table = { + header => [ 'column 1 header', 'column 2 header', ... ], # Optional + + rows => [ + ['row 1 column 1', 'row 1, column 2', ... ], + ['row 2 column 1', 'row 2, column 2', ... ], + ... + ], + + # Allow the renderer to hide empty columns when true, Optional + collapse => $BOOL, + + # List by name or number columns that should never be collapsed + no_collapse => \@LIST, + } + +=item $short_string = $info->{tag} + +=item $short_string = $info->tag() + +Short tag to categorize the info. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $info->{debug} + +=item $bool = $info->debug() + +Set this to true if the message is critical, or explains a failure. This is +info that should be displayed by formatters even in less-verbose modes. + +When false the information is not considered critical and may not be rendered +in less-verbose modes. + +=item $bool = $info->{important} + +=item $bool = $info->important + +This should be set for non debug messages that are still important enough to +show when a formatter is in quiet mode. A formatter should send these to STDOUT +not STDERR, but should show them even in non-verbose mode. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Meta.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Meta.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Meta.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Meta.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,104 @@ +package Test2::EventFacet::Meta; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use vars qw/$AUTOLOAD/; + +# replace set_details +{ + no warnings 'redefine'; + sub set_details { $_[0]->{'set_details'} } +} + +sub can { + my $self = shift; + my ($name) = @_; + + my $existing = $self->SUPER::can($name); + return $existing if $existing; + + # Only vivify when called on an instance, do not vivify for a class. There + # are a lot of magic class methods used in things like serialization (or + # the forks.pm module) which cause problems when vivified. + return undef unless ref($self); + + my $sub = sub { $_[0]->{$name} }; + { + no strict 'refs'; + *$name = $sub; + } + + return $sub; +} + +sub AUTOLOAD { + my $name = $AUTOLOAD; + $name =~ s/^.*:://g; + my $sub = $_[0]->can($name); + goto &$sub; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Meta - Facet for meta-data + +=head1 DESCRIPTION + +This facet can contain any random meta-data that has been attached to the +event. + +=head1 METHODS AND FIELDS + +Any/all fields and accessors are autovivified into existence. There is no way +to know what metadata may be added, so any is allowed. + +=over 4 + +=item $anything = $meta->{anything} + +=item $anything = $meta->anything() + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Parent.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Parent.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Parent.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Parent.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,98 @@ +package Test2::EventFacet::Parent; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Carp qw/confess/; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -hid -children -buffered }; + +sub init { + confess "Attribute 'hid' must be set" + unless defined $_[0]->{+HID}; + + $_[0]->{+CHILDREN} ||= []; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Parent - Facet for events contains other events + +=head1 DESCRIPTION + +This facet is used when an event contains other events, such as a subtest. + +=head1 FIELDS + +=over 4 + +=item $string = $parent->{details} + +=item $string = $parent->details() + +Human readable description of the event. + +=item $hid = $parent->{hid} + +=item $hid = $parent->hid() + +Hub ID of the hub that is represented in the parent-child relationship. + +=item $arrayref = $parent->{children} + +=item $arrayref = $parent->children() + +Arrayref containing the facet-data hashes of events nested under this one. + +I + +=item $bool = $parent->{buffered} + +=item $bool = $parent->buffered() + +True if the subtest is buffered (meaning the formatter has probably not seen +them yet). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Plan.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Plan.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Plan.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Plan.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,94 @@ +package Test2::EventFacet::Plan; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -count -skip -none }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Plan - Facet for setting the plan + +=head1 DESCRIPTION + +Events use this facet when they need to set the plan. + +=head1 FIELDS + +=over 4 + +=item $string = $plan->{details} + +=item $string = $plan->details() + +Human readable explanation for the plan being set. This is normally not +rendered by most formatters except when the C field is also set. + +=item $positive_int = $plan->{count} + +=item $positive_int = $plan->count() + +Set the number of expected assertions. This should usually be set to C<0> when +C or C are also set. + +=item $bool = $plan->{skip} + +=item $bool = $plan->skip() + +When true the entire test should be skipped. This is usually paired with an +explanation in the C
field, and a C facet that has +C set to C<0>. + +=item $bool = $plan->{none} + +=item $bool = $plan->none() + +This is mainly used by legacy L tests which set the plan to C, a construct that predates the much better C. + +If you are using this in non-legacy code you may need to reconsider the course +of your life, maybe a hermitage would suite you? + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Render.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Render.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Render.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Render.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,106 @@ +package Test2::EventFacet::Render; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -facet -mode }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Render - Facet that dictates how to render an event. + +=head1 DESCRIPTION + +This facet is used to dictate how the event should be rendered by the standard +test2 rendering tools. If this facet is present then ONLY what is specified by +it will be rendered. It is assumed that anything important or note-worthy will +be present here, no other facets will be considered for rendering/display. + +This facet is a list type, you can add as many items as needed. + +=head1 FIELDS + +=over 4 + +=item $string = $render->[#]->{details} + +=item $string = $render->[#]->details() + +Human readable text for display. + +=item $string = $render->[#]->{tag} + +=item $string = $render->[#]->tag() + +Tag that should prefix/identify the main text. + +=item $string = $render->[#]->{facet} + +=item $string = $render->[#]->facet() + +Optional, if the display text was generated from another facet this should +state what facet it was. + +=item $mode = $render->[#]->{mode} + +=item $mode = $render->[#]->mode() + +=over 4 + +=item calculated + +Calculated means the facet was generated from another facet. Calculated facets +may be cleared and regenerated whenever the event state changes. + +=item replace + +Replace means the facet is intended to replace the normal rendering of the +event. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet/Trace.pm ddclient-3.10.0/t/lib/Test2/EventFacet/Trace.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet/Trace.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet/Trace.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,279 @@ +package Test2::EventFacet::Trace; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } + +use Test2::Util qw/get_tid pkg_to_file gen_uid/; +use Carp qw/confess/; + +use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid}; + +{ + no warnings 'once'; + *DETAIL = \&DETAILS; + *detail = \&details; + *set_detail = \&set_details; +} + +sub init { + confess "The 'frame' attribute is required" + unless $_[0]->{+FRAME}; + + $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; + + unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) { + $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; + $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; + } +} + +sub snapshot { + my ($orig, @override) = @_; + bless {%$orig, @override}, __PACKAGE__; +} + +sub signature { + my $self = shift; + + # Signature is only valid if all of these fields are defined, there is no + # signature if any is missing. '0' is ok, but '' is not. + return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( + $self->{+CID}, + $self->{+PID}, + $self->{+TID}, + $self->{+FRAME}->[1], + $self->{+FRAME}->[2], + ); +} + +sub debug { + my $self = shift; + return $self->{+DETAILS} if $self->{+DETAILS}; + my ($pkg, $file, $line) = $self->call; + return "at $file line $line"; +} + +sub alert { + my $self = shift; + my ($msg) = @_; + warn $msg . ' ' . $self->debug . ".\n"; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + die $msg . ' ' . $self->debug . ".\n"; +} + +sub call { @{$_[0]->{+FRAME}} } + +sub package { $_[0]->{+FRAME}->[0] } +sub file { $_[0]->{+FRAME}->[1] } +sub line { $_[0]->{+FRAME}->[2] } +sub subname { $_[0]->{+FRAME}->[3] } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Trace - Debug information for events + +=head1 DESCRIPTION + +The L object, as well as all L types need to +have access to information about where they were created. This object +represents that information. + +=head1 SYNOPSIS + + use Test2::EventFacet::Trace; + + my $trace = Test2::EventFacet::Trace->new( + frame => [$package, $file, $line, $subname], + ); + +=head1 FACET FIELDS + +=over 4 + +=item $string = $trace->{details} + +=item $string = $trace->details() + +Used as a custom trace message that will be used INSTEAD of +C<< at line >> when calling C<< $trace->debug >>. + +=item $frame = $trace->{frame} + +=item $frame = $trace->frame() + +Get the call frame arrayref. + +=item $int = $trace->{pid} + +=item $int = $trace->pid() + +The process ID in which the event was generated. + +=item $int = $trace->{tid} + +=item $int = $trace->tid() + +The thread ID in which the event was generated. + +=item $id = $trace->{cid} + +=item $id = $trace->cid() + +The ID of the context that was used to create the event. + +=item $uuid = $trace->{uuid} + +=item $uuid = $trace->uuid() + +The UUID of the context that was used to create the event. (If uuid tagging was +enabled) + +=back + +=head2 DISCOURAGED HUB RELATED FIELDS + +These fields were not always set properly by tools. These are B +deprecated by the L facets. These fields are not +required, and may only reflect the hub that was current when the event was +created, which is not necessarily the same as the hub the event was sent +through. + +Some tools did do a good job setting these to the correct hub, but you cannot +always rely on that. Use the 'hubs' facet list instead. + +=over 4 + +=item $hid = $trace->{hid} + +=item $hid = $trace->hid() + +The ID of the hub that was current when the event was created. + +=item $huuid = $trace->{huuid} + +=item $huuid = $trace->huuid() + +The UUID of the hub that was current when the event was created. (If uuid +tagging was enabled). + +=item $int = $trace->{nested} + +=item $int = $trace->nested() + +How deeply nested the event is. + +=item $bool = $trace->{buffered} + +=item $bool = $trace->buffered() + +True if the event was buffered and not sent to the formatter independent of a +parent (This should never be set when nested is C<0> or C). + +=back + +=head1 METHODS + +B All facet frames are also methods. + +=over 4 + +=item $trace->set_detail($msg) + +=item $msg = $trace->detail + +Used to get/set a custom trace message that will be used INSTEAD of +C<< at line >> when calling C<< $trace->debug >>. + +C is an alias to the C
facet field for backwards +compatibility. + +=item $str = $trace->debug + +Typically returns the string C<< at line >>. If C is set +then its value will be returned instead. + +=item $trace->alert($MESSAGE) + +This issues a warning at the frame (filename and line number where +errors should be reported). + +=item $trace->throw($MESSAGE) + +This throws an exception at the frame (filename and line number where +errors should be reported). + +=item ($package, $file, $line, $subname) = $trace->call() + +Get the caller details for the debug-info. This is where errors should be +reported. + +=item $pkg = $trace->package + +Get the debug-info package. + +=item $file = $trace->file + +Get the debug-info filename. + +=item $line = $trace->line + +Get the debug-info line number. + +=item $subname = $trace->subname + +Get the debug-info subroutine name. + +=item $sig = trace->signature + +Get a signature string that identifies this trace. This is used to check if +multiple events are related. The signature includes pid, tid, file, line +number, and the cid. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/EventFacet.pm ddclient-3.10.0/t/lib/Test2/EventFacet.pm --- ddclient-3.9.1/t/lib/Test2/EventFacet.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/EventFacet.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,93 @@ +package Test2::EventFacet; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Test2::Util::HashBase qw/-details/; +use Carp qw/croak/; + +my $SUBLEN = length(__PACKAGE__ . '::'); +sub facet_key { + my $key = ref($_[0]) || $_[0]; + substr($key, 0, $SUBLEN, ''); + return lc($key); +} + +sub is_list { 0 } + +sub clone { + my $self = shift; + my $type = ref($self); + return bless {%$self, @_}, $type; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet - Base class for all event facets. + +=head1 DESCRIPTION + +Base class for all event facets. + +=head1 METHODS + +=over 4 + +=item $key = $facet_class->facet_key() + +This will return the key for the facet in the facet data hash. + +=item $bool = $facet_class->is_list() + +This will return true if the facet should be in a list instead of a single +item. + +=item $clone = $facet->clone() + +=item $clone = $facet->clone(%replace) + +This will make a shallow clone of the facet. You may specify fields to override +as arguments. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Event.pm ddclient-3.10.0/t/lib/Test2/Event.pm --- ddclient-3.9.1/t/lib/Test2/Event.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Event.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,778 @@ +package Test2::Event; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Scalar::Util qw/blessed reftype/; +use Carp qw/croak/; + +use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/; +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util qw/pkg_to_file gen_uid/; + +use Test2::EventFacet::About(); +use Test2::EventFacet::Amnesty(); +use Test2::EventFacet::Assert(); +use Test2::EventFacet::Control(); +use Test2::EventFacet::Error(); +use Test2::EventFacet::Info(); +use Test2::EventFacet::Meta(); +use Test2::EventFacet::Parent(); +use Test2::EventFacet::Plan(); +use Test2::EventFacet::Trace(); +use Test2::EventFacet::Hub(); + +# Legacy tools will expect this to be loaded now +require Test2::Util::Trace; + +my %LOADED_FACETS = ( + 'about' => 'Test2::EventFacet::About', + 'amnesty' => 'Test2::EventFacet::Amnesty', + 'assert' => 'Test2::EventFacet::Assert', + 'control' => 'Test2::EventFacet::Control', + 'errors' => 'Test2::EventFacet::Error', + 'info' => 'Test2::EventFacet::Info', + 'meta' => 'Test2::EventFacet::Meta', + 'parent' => 'Test2::EventFacet::Parent', + 'plan' => 'Test2::EventFacet::Plan', + 'trace' => 'Test2::EventFacet::Trace', + 'hubs' => 'Test2::EventFacet::Hub', +); + +sub FACET_TYPES { sort values %LOADED_FACETS } + +sub load_facet { + my $class = shift; + my ($facet) = @_; + + return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet}; + + my @check = ($facet); + if ('s' eq substr($facet, -1, 1)) { + push @check => substr($facet, 0, -1); + } + else { + push @check => $facet . 's'; + } + + my $found; + for my $check (@check) { + my $mod = "Test2::EventFacet::" . ucfirst($facet); + my $file = pkg_to_file($mod); + next unless eval { require $file; 1 }; + $found = $mod; + last; + } + + return undef unless $found; + $LOADED_FACETS{$facet} = $found; +} + +sub causes_fail { 0 } +sub increments_count { 0 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } + +sub callback { } + +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub summary { ref($_[0]) } + +sub related { + my $self = shift; + my ($event) = @_; + + my $tracea = $self->trace or return undef; + my $traceb = $event->trace or return undef; + + my $uuida = $tracea->uuid; + my $uuidb = $traceb->uuid; + if ($uuida && $uuidb) { + return 1 if $uuida eq $uuidb; + return 0; + } + + my $siga = $tracea->signature or return undef; + my $sigb = $traceb->signature or return undef; + + return 1 if $siga eq $sigb; + return 0; +} + +sub add_hub { + my $self = shift; + unshift @{$self->{+HUBS}} => @_; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); + + push @{$self->{+AMNESTY}} => $am; + } +} + +sub eid { $_[0]->{+_EID} ||= gen_uid() } + +sub common_facet_data { + my $self = shift; + + my %out; + + $out{about} = {package => ref($self) || undef}; + if (my $uuid = $self->uuid) { + $out{about}->{uuid} = $uuid; + } + + $out{about}->{eid} = $self->{+_EID} || $self->eid; + + if (my $trace = $self->trace) { + $out{trace} = { %$trace }; + } + + if (my $hubs = $self->hubs) { + $out{hubs} = $hubs; + } + + $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] + if $self->{+AMNESTY}; + + if (my $meta = $self->meta_facet_data) { + $out{meta} = $meta; + } + + return \%out; +} + +sub meta_facet_data { + my $self = shift; + + my $key = Test2::Util::ExternalMeta::META_KEY(); + + my $hash = $self->{$key} or return undef; + return {%$hash}; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary || undef; + $out->{about}->{no_display} = $self->no_display || undef; + + # Might be undef, we want to preserve that + my $terminate = $self->terminate; + $out->{control} = { + global => $self->global || 0, + terminate => $terminate, + has_callback => $self->can('callback') == \&callback ? 0 : 1, + }; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->causes_fail ? 0 : 1, + details => $self->summary, + } if $self->increments_count; + + $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; + + if (my @plan = $self->sets_plan) { + $out->{plan} = {}; + + $out->{plan}->{count} = $plan[0] if defined $plan[0]; + $out->{plan}->{details} = $plan[2] if defined $plan[2]; + + if ($plan[1]) { + $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; + $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; + } + + $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; + } + + if ($self->causes_fail && !$out->{assert}) { + $out->{errors} = [ + { + tag => 'FAIL', + fail => 1, + details => $self->summary, + } + ]; + } + + my %IGNORE = (trace => 1, about => 1, control => 1); + my $do_info = !grep { !$IGNORE{$_} } keys %$out; + + if ($do_info && !$self->no_display && $self->diagnostics) { + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->summary, + } + ]; + } + + return $out; +} + +sub facets { + my $self = shift; + my %out; + + my $data = $self->facet_data; + my @errors = $self->validate_facet_data($data); + die join "\n" => @errors if @errors; + + for my $facet (keys %$data) { + my $class = $self->load_facet($facet); + my $val = $data->{$facet}; + + unless($class) { + $out{$facet} = $val; + next; + } + + my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0; + if ($is_list) { + $out{$facet} = [map { $class->new($_) } @$val]; + } + else { + $out{$facet} = $class->new($val); + } + } + + return \%out; +} + +sub validate_facet_data { + my $class_or_self = shift; + my ($f, %params); + + $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH'; + %params = @_; + + $f ||= $class_or_self->facet_data if blessed($class_or_self); + croak "No facet data" unless $f; + + my @errors; + + for my $k (sort keys %$f) { + my $fclass = $class_or_self->load_facet($k); + + push @errors => "Could not find a facet class for facet '$k'" + if $params{require_facet_class} && !$fclass; + + next unless $fclass; + + my $v = $f->{$k}; + next unless defined($v); # undef is always fine + + my $is_list = $fclass->is_list(); + my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0; + + push @errors => "Facet '$k' should be a list, but got a single item ($v)" + if $is_list && !$got_list; + + push @errors => "Facet '$k' should not be a list, but got a a list ($v)" + if $got_list && !$is_list; + } + + return @errors; +} + +sub nested { + my $self = shift; + + Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") + if $ENV{AUTHOR_TESTING}; + + if (my $hubs = $self->{+HUBS}) { + return $hubs->[0]->{nested} if @$hubs; + } + + my $trace = $self->{+TRACE} or return undef; + return $trace->{nested}; +} + +sub in_subtest { + my $self = shift; + + Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") + if $ENV{AUTHOR_TESTING}; + + my $hubs = $self->{+HUBS}; + if ($hubs && @$hubs) { + return undef unless $hubs->[0]->{nested}; + return $hubs->[0]->{hid} + } + + my $trace = $self->{+TRACE} or return undef; + return undef unless $trace->{nested}; + return $trace->{hid}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event - Base class for events + +=head1 DESCRIPTION + +Base class for all event objects that get passed through +L. + +=head1 SYNOPSIS + + package Test2::Event::MyEvent; + use strict; + use warnings; + + # This will make our class an event subclass (required) + use base 'Test2::Event'; + + # Add some accessors (optional) + # You are not obligated to use HashBase, you can use any object tool you + # want, or roll your own accessors. + use Test2::Util::HashBase qw/foo bar baz/; + + # Use this if you want the legacy API to be written for you, for this to + # work you will need to implement a facet_data() method. + use Test2::Util::Facets2Legacy; + + # Chance to initialize some defaults + sub init { + my $self = shift; + # no other args in @_ + + $self->set_foo('xxx') unless defined $self->foo; + + ... + } + + # This is the new way for events to convey data to the Test2 system + sub facet_data { + my $self = shift; + + # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' + my $facet_data = $self->common_facet_data(); + + # Are you making an assertion? + $facet_data->{assert} = {pass => 1, details => 'my assertion'}; + ... + + return $facet_data; + } + + 1; + +=head1 METHODS + +=head2 GENERAL + +=over 4 + +=item $trace = $e->trace + +Get a snapshot of the L as it was when this event was +generated + +=item $bool_or_undef = $e->related($e2) + +Check if 2 events are related. In this case related means their traces share a +signature meaning they were created with the same context (or at the very least +by contexts which share an id, which is the same thing unless someone is doing +something very bad). + +This can be used to reliably link multiple events created by the same tool. For +instance a failing test like C will generate 2 events, one being +a L, the other being a L, both of these +events are related having been created under the same context and by the same +initial tool (though multiple tools may have been nested under the initial +one). + +This will return C if the relationship cannot be checked, which happens +if either event has an incomplete or missing trace. This will return C<0> if +the traces are complete, but do not match. C<1> will be returned if there is a +match. + +=item $e->add_amnesty({tag => $TAG, details => $DETAILS}); + +This can be used to add amnesty to this event. Amnesty only effects failing +assertions in most cases, but some formatters may display them for passing +assertions, or even non-assertions as well. + +Amnesty will prevent a failed assertion from causing the overall test to fail. +In other words it marks a failure as expected and allowed. + +B This is how 'TODO' is implemented under the hood. TODO is essentially +amnesty with the 'TODO' tag. The details are the reason for the TODO. + +=item $uuid = $e->uuid + +If UUID tagging is enabled (See L) then any event that has made its +way through a hub will be tagged with a UUID. A newly created event will not +yet be tagged in most cases. + +=item $class = $e->load_facet($name) + +This method is used to load a facet by name (or key). It will attempt to load +the facet class, if it succeeds it will return the class it loaded. If it fails +it will return C. This caches the result at the class level so that +future calls will be faster. + +The C<$name> variable should be the key used to access the facet in a facets +hashref. For instance the assertion facet has the key 'assert', the information +facet has the 'info' key, and the error facet has the key 'errors'. You may +include or omit the 's' at the end of the name, the method is smart enough to +try both the 's' and no-'s' forms, it will check what you provided first, and +if that is not found it will add or strip the 's and try again. + +=item @classes = $e->FACET_TYPES() + +=item @classes = Test2::Event->FACET_TYPES() + +This returns a list of all facets that have been loaded using the +C method. This will not return any classes that have not been +loaded, or have been loaded directly without a call to C. + +B The core facet types are automatically loaded and populated in this +list. + +=back + +=head2 NEW API + +=over 4 + +=item $hashref = $e->common_facet_data(); + +This can be used by subclasses to generate a starting facet data hashref. This +will populate the hashref with the trace, meta, amnesty, and about facets. +These facets are nearly always produced the same way for all events. + +=item $hashref = $e->facet_data() + +If you do not override this then the default implementation will attempt to +generate facets from the legacy API. This generation is limited only to what +the legacy API can provide. It is recommended that you override this method and +write out explicit facet data. + +=item $hashref = $e->facets() + +This takes the hashref from C and blesses each facet into the +proper C subclass. If no class can be found for any given +facet it will be passed along unchanged. + +=item @errors = $e->validate_facet_data(); + +=item @errors = $e->validate_facet_data(%params); + +=item @errors = $e->validate_facet_data(\%facets, %params); + +=item @errors = Test2::Event->validate_facet_data(%params); + +=item @errors = Test2::Event->validate_facet_data(\%facets, %params); + +This method will validate facet data and return a list of errors. If no errors +are found this will return an empty list. + +This can be called as an object method with no arguments, in which case the +C method will be called to get the facet data to be validated. + +When used as an object method the C<\%facet_data> argument may be omitted. + +When used as a class method the C<\%facet_data> argument is required. + +Remaining arguments will be slurped into a C<%params> hash. + +Currently only 1 parameter is defined: + +=over 4 + +=item require_facet_class => $BOOL + +When set to true (default is false) this will reject any facets where a facet +class cannot be found. Normally facets without classes are assumed to be custom +and are ignored. + +=back + +=back + +=head3 WHAT ARE FACETS? + +Facets are how events convey their purpose to the Test2 internals and +formatters. An event without facets will have no intentional effect on the +overall test state, and will not be displayed at all by most formatters, except +perhaps to say that an event of an unknown type was seen. + +Facets are produced by the C subroutine, which you should +nearly-always override. C is expected to return a hashref where +each key is the facet type, and the value is either a hashref with the data for +that facet, or an array of hashrefs. Some facets must be defined as single +hashrefs, some must be defined as an array of hashrefs, No facets allow both. + +C B bless the data it returns, the main hashref, and +nested facet hashrefs B be bare, though items contained within each +facet may be blessed. The data returned by this method B also be copies +of the internal data in order to prevent accidental state modification. + +C takes the data from C and blesses it into the +C packages. This is rarely used however, the EventFacet +packages are primarily for convenience and documentation. The EventFacet +classes are not used at all internally, instead the raw data is used. + +Here is a list of facet types by package. The packages are not used internally, +but are where the documentation for each type is kept. + +B Every single facet type has the C<'details'> field. This field is +always intended for human consumption, and when provided, should explain the +'why' for the facet. All other fields are facet specific. + +=over 4 + +=item about => {...} + +L + +This contains information about the event itself such as the event package +name. The C
field for this facet is an overall summary of the event. + +=item assert => {...} + +L + +This facet is used if an assertion was made. The C
field of this facet +is the description of the assertion. + +=item control => {...} + +L + +This facet is used to tell the L about special actions the +event causes. Things like halting all testing, terminating the current test, +etc. In this facet the C
field explains why any special action was +taken. + +B This is how bail-out is implemented. + +=item meta => {...} + +L + +The meta facet contains all the meta-data attached to the event. In this case +the C
field has no special meaning, but may be present if something +sets the 'details' meta-key on the event. + +=item parent => {...} + +L + +This facet contains nested events and similar details for subtests. In this +facet the C
field will typically be the name of the subtest. + +=item plan => {...} + +L + +This facet tells the system that a plan has been set. The C
field of +this is usually left empty, but when present explains why the plan is what it +is, this is most useful if the plan is to skip-all. + +=item trace => {...} + +L + +This facet contains information related to when and where the event was +generated. This is how the test file and line number of a failure is known. +This facet can also help you to tell if tests are related. + +In this facet the C
field overrides the "failed at test_file.t line +42." message provided on assertion failure. + +=item amnesty => [{...}, ...] + +L + +The amnesty facet is a list instead of a single item, this is important as +amnesty can come from multiple places at once. + +For each instance of amnesty the C
field explains why amnesty was +granted. + +B Outside of formatters amnesty only acts to forgive a failing +assertion. + +=item errors => [{...}, ...] + +L + +The errors facet is a list instead of a single item, any number of errors can +be listed. In this facet C
describes the error, or may contain the raw +error message itself (such as an exception). In perl exception may be blessed +objects, as such the raw data for this facet may contain nested items which are +blessed. + +Not all errors are considered fatal, there is a C field that must be set +for an error to cause the test to fail. + +B This facet is unique in that the field name is 'errors' while the +package is 'Error'. This is because this is the only facet type that is both a +list, and has a name where the plural is not the same as the singular. This may +cause some confusion, but I feel it will be less confusing than the +alternative. + +=item info => [{...}, ...] + +L + +The 'info' facet is a list instead of a single item, any quantity of extra +information can be attached to an event. Some information may be critical +diagnostics, others may be simply commentary in nature, this is determined by +the C flag. + +For this facet the C
flag is the info itself. This info may be a +string, or it may be a data structure to display. This is one of the few facet +types that may contain blessed items. + +=back + +=head2 LEGACY API + +=over 4 + +=item $bool = $e->causes_fail + +Returns true if this event should result in a test failure. In general this +should be false. + +=item $bool = $e->increments_count + +Should be true if this event should result in a test count increment. + +=item $e->callback($hub) + +If your event needs to have extra effects on the L you can override +this method. + +This is called B your event is passed to the formatter. + +=item $num = $e->nested + +If this event is nested inside of other events, this should be the depth of +nesting. (This is mainly for subtests) + +=item $bool = $e->global + +Set this to true if your event is global, that is ALL threads and processes +should see it no matter when or where it is generated. This is not a common +thing to want, it is used by bail-out and skip_all to end testing. + +=item $code = $e->terminate + +This is called B your event has been passed to the formatter. This +should normally return undef, only change this if your event should cause the +test to exit immediately. + +If you want this event to cause the test to exit you should return the exit +code here. Exit code of 0 means exit success, any other integer means exit with +failure. + +This is used by L to exit 0 when the plan is +'skip_all'. This is also used by L to force the test +to exit with a failure. + +This is called after the event has been sent to the formatter in order to +ensure the event is seen and understood. + +=item $msg = $e->summary + +This is intended to be a human readable summary of the event. This should +ideally only be one line long, but you can use multiple lines if necessary. This +is intended for human consumption. You do not need to make it easy for machines +to understand. + +The default is to simply return the event package name. + +=item ($count, $directive, $reason) = $e->sets_plan() + +Check if this event sets the testing plan. It will return an empty list if it +does not. If it does set the plan it will return a list of 1 to 3 items in +order: Expected Test Count, Test Directive, Reason for directive. + +=item $bool = $e->diagnostics + +True if the event contains diagnostics info. This is useful because a +non-verbose harness may choose to hide events that are not in this category. +Some formatters may choose to send these to STDERR instead of STDOUT to ensure +they are seen. + +=item $bool = $e->no_display + +False by default. This will return true on events that should not be displayed +by formatters. + +=item $id = $e->in_subtest + +If the event is inside a subtest this should have the subtest ID. + +=item $id = $e->subtest_id + +If the event is a final subtest event, this should contain the subtest ID. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Formatter/TAP.pm ddclient-3.10.0/t/lib/Test2/Formatter/TAP.pm --- ddclient-3.9.1/t/lib/Test2/Formatter/TAP.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Formatter/TAP.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,528 @@ +package Test2::Formatter::TAP; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Test2::Util qw/clone_io/; + +use Test2::Util::HashBase qw{ + no_numbers handles _encoding _last_fh + -made_assertion +}; + +sub OUT_STD() { 0 } +sub OUT_ERR() { 1 } + +BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } + +my $supports_tables; +sub supports_tables { + if (!defined $supports_tables) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + $supports_tables + = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) + || eval { require Term::Table; require Term::Table::Util; 1 } + || 0; + } + return $supports_tables; +} + +sub _autoflush { + my($fh) = pop; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + +_autoflush(\*STDOUT); +_autoflush(\*STDERR); + +sub hide_buffered { 1 } + +sub init { + my $self = shift; + + $self->{+HANDLES} ||= $self->_open_handles; + if(my $enc = delete $self->{encoding}) { + $self->encoding($enc); + } +} + +sub _open_handles { + my $self = shift; + + require Test2::API; + my $out = clone_io(Test2::API::test2_stdout()); + my $err = clone_io(Test2::API::test2_stderr()); + + _autoflush($out); + _autoflush($err); + + return [$out, $err]; +} + +sub encoding { + my $self = shift; + + if ($] ge "5.007003" and @_) { + my ($enc) = @_; + my $handles = $self->{+HANDLES}; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + if ($enc =~ m/^utf-?8$/i) { + binmode($_, ":utf8") for @$handles; + } + else { + binmode($_, ":encoding($enc)") for @$handles; + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num, $f) = @_; + + # The most common case, a pass event with no amnesty and a normal name. + return if $self->print_optimal_pass($e, $num); + + $f ||= $e->facet_data; + + $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + my @tap = $self->event_tap($f, $num) or return; + + $self->{+MADE_ASSERTION} = 1 if $f->{assert}; + + my $nesting = $f->{trace}->{nested} || 0; + my $handles = $self->{+HANDLES}; + my $indent = ' ' x $nesting; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + for my $set (@tap) { + no warnings 'uninitialized'; + my ($hid, $msg) = @$set; + next unless $msg; + my $io = $handles->[$hid] or next; + + print $io "\n" + if $ENV{HARNESS_ACTIVE} + && $hid == OUT_ERR + && $self->{+_LAST_FH} != $io + && $msg =~ m/^#\s*Failed( \(TODO\))? test /; + + $msg =~ s/^/$indent/mg if $nesting; + print $io $msg; + $self->{+_LAST_FH} = $io; + } +} + +sub print_optimal_pass { + my ($self, $e, $num) = @_; + + my $type = ref($e); + + # Only optimal if this is a Pass or a passing Ok + return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); + + # Amnesty requires further processing (todo is a form of amnesty) + return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); + + # A name with a newline or hash symbol needs extra processing + return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); + + my $ok = 'ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; + $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; + + if (my $nesting = $e->{trace}->{nested}) { + my $indent = ' ' x $nesting; + $ok = "$indent$ok"; + } + + my $io = $self->{+HANDLES}->[OUT_STD]; + + local($\, $,) = (undef, '') if $\ || $,; + print $io $ok; + $self->{+_LAST_FH} = $io; + + return 1; +} + +sub event_tap { + my ($self, $f, $num) = @_; + + my @tap; + + # If this IS the first event the plan should come first + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; + + # The assertion is most important, if present. + if ($f->{assert}) { + push @tap => $self->assert_tap($f, $num); + push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; + } + + # Almost as important as an assertion + push @tap => $self->error_tap($f) if $f->{errors}; + + # Now lets see the diagnostics messages + push @tap => $self->info_tap($f) if $f->{info}; + + # If this IS NOT the first event the plan should come last + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; + + # Bail out + push @tap => $self->halt_tap($f) if $f->{control}->{halt}; + + return @tap if @tap; + return @tap if $f->{control}->{halt}; + return @tap if grep { $f->{$_} } qw/assert plan info errors/; + + # Use the summary as a fallback if nothing else is usable. + return $self->summary_tap($f, $num); +} + +sub error_tap { + my $self = shift; + my ($f) = @_; + + my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } + + [$IO, "$msg\n"]; + } @{$f->{errors}}; +} + +sub plan_tap { + my $self = shift; + my ($f) = @_; + my $plan = $f->{plan} or return; + + return if $plan->{none}; + + if ($plan->{skip}) { + my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; + chomp($reason); + return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; + } + + return [OUT_STD, "1.." . $plan->{count} . "\n"]; +} + +sub no_subtest_space { 0 } +sub assert_tap { + my $self = shift; + my ($f, $num) = @_; + + my $assert = $f->{assert} or return; + my $pass = $assert->{pass}; + my $name = $assert->{details}; + + my $ok = $pass ? 'ok' : 'not ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; + + # The regex form is ~250ms, the index form is ~50ms + my @extra; + defined($name) && ( + (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), + ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) + ); + + my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; + my $extra_indent = ''; + + my ($directives, $reason, $is_skip); + if ($f->{amnesty}) { + my %directives; + + for my $am (@{$f->{amnesty}}) { + next if $am->{inherited}; + my $tag = $am->{tag} or next; + $is_skip = 1 if $tag eq 'skip'; + + $directives{$tag} ||= $am->{details}; + } + + my %seen; + + # Sort so that TODO comes before skip even on systems where lc sorts + # before uc, as other code depends on that ordering. + my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives; + + $directives = ' # ' . join ' & ' => @order; + + for my $tag ('skip', @order) { + next unless defined($directives{$tag}) && length($directives{$tag}); + $reason = $directives{$tag}; + last; + } + } + + $ok .= " - $name" if defined $name && !($is_skip && !$name); + + my @subtap; + if ($f->{parent} && $f->{parent}->{buffered}) { + $ok .= ' {'; + + # In a verbose harness we indent the extra since they will appear + # inside the subtest braces. This helps readability. In a non-verbose + # harness we do not do this because it is less readable. + if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { + $extra_indent = " "; + $extra_space = ' '; + } + + # Render the sub-events, we use our own counter for these. + my $count = 0; + @subtap = map { + my $f2 = $_; + + # Bump the count for any event that should bump it. + $count++ if $f2->{assert}; + + # This indents all output lines generated for the sub-events. + # index 0 is the filehandle, index 1 is the message we want to indent. + map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count); + } @{$f->{parent}->{children}}; + + push @subtap => [OUT_STD, "}\n"]; + } + + if ($directives) { + $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; + $ok .= $directives; + $ok .= " $reason" if defined($reason); + } + + $extra_space = ' ' if $self->no_subtest_space; + + my @out = ([OUT_STD, "$ok\n"]); + push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; + push @out => @subtap; + + return @out; +} + +sub debug_tap { + my ($self, $f, $num) = @_; + + # Figure out the debug info, this is typically the file name and line + # number, but can also be a custom message. If no trace object is provided + # then we have nothing useful to display. + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug = "[No trace info available]"; + if ($trace->{details}) { + $debug = $trace->{details}; + } + elsif ($trace->{frame}) { + my ($pkg, $file, $line) = @{$trace->{frame}}; + $debug = "at $file line $line." if $file && $line; + } + + my $amnesty = $f->{amnesty} && @{$f->{amnesty}} + ? ' (with amnesty)' + : ''; + + # Create the initial diagnostics. If the test has a name we put the debug + # info on a second line, this behavior is inherited from Test::Builder. + my $msg = defined($name) + ? qq[# Failed test${amnesty} '$name'\n# $debug\n] + : qq[# Failed test${amnesty} $debug\n]; + + my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; + + return [$IO, $msg]; +} + +sub halt_tap { + my ($self, $f) = @_; + + return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; + my $details = $f->{control}->{details}; + + return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); + return [OUT_STD, "Bail out! $details\n"]; +} + +sub info_tap { + my ($self, $f) = @_; + + return map { + my $details = $_->{details}; + my $table = $_->{table}; + + my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; + + my $msg; + if ($table && $self->supports_tables) { + $msg = join "\n" => map { "# $_" } Term::Table->new( + header => $table->{header}, + rows => $table->{rows}, + collapse => $table->{collapse}, + no_collapse => $table->{no_collapse}, + sanitize => 1, + mark_tail => 1, + max_width => $self->calc_table_size($f), + )->render(); + } + elsif (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } + + [$IO, "$msg\n"]; + } @{$f->{info}}; +} + +sub summary_tap { + my ($self, $f, $num) = @_; + + return if $f->{about}->{no_display}; + + my $summary = $f->{about}->{details} or return; + chomp($summary); + $summary =~ s/^/# /smg; + + return [OUT_STD, "$summary\n"]; +} + +sub calc_table_size { + my $self = shift; + my ($f) = @_; + + my $term = Term::Table::Util::term_size(); + my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix + my $total = $term - $nesting; + + # Sane minimum width, any smaller and we are asking for pain + return 50 if $total < 50; + + return $total; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::TAP - Standard TAP formatter + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test2::Formatter::TAP; + my $tap = Test2::Formatter::TAP->new(); + + # Switch to utf8 + $tap->encoding('utf8'); + + $tap->write($event, $number); # Output an event + +=head1 METHODS + +=over 4 + +=item $bool = $tap->no_numbers + +=item $tap->set_no_numbers($bool) + +Use to turn numbers on and off. + +=item $arrayref = $tap->handles + +=item $tap->set_handles(\@handles); + +Can be used to get/set the filehandles. Indexes are identified by the +C and C constants. + +=item $encoding = $tap->encoding + +=item $tap->encoding($encoding) + +Get or set the encoding. By default no encoding is set, the original settings +of STDOUT and STDERR are used. + +This directly modifies the stored filehandles, it does not create new ones. + +=item $tap->write($e, $num) + +Write an event to the console. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Formatter.pm ddclient-3.10.0/t/lib/Test2/Formatter.pm --- ddclient-3.9.1/t/lib/Test2/Formatter.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Formatter.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,158 @@ +package Test2::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + require Test2::API; + Test2::API::test2_formatter_add($class); +} + +sub new_root { + my $class = shift; + return $class->new(@_); +} + +sub supports_tables { 0 } + +sub hide_buffered { 1 } + +sub terminate { } + +sub finalize { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter - Namespace for formatters. + +=head1 DESCRIPTION + +This is the namespace for formatters. This is an empty package. + +=head1 CREATING FORMATTERS + +A formatter is any package or object with a C method. + + package Test2::Formatter::Foo; + use strict; + use warnings; + + sub write { + my $self_or_class = shift; + my ($event, $assert_num) = @_; + ... + } + + sub hide_buffered { 1 } + + sub terminate { } + + sub finalize { } + + sub supports_tables { return $BOOL } + + sub new_root { + my $class = shift; + ... + $class->new(@_); + } + + 1; + +The C method is a method, so it either gets a class or instance. The two +arguments are the C<$event> object it should record, and the C<$assert_num> +which is the number of the current assertion (ok), or the last assertion if +this event is not itself an assertion. The assertion number may be any integer 0 +or greater, and may be undefined in some cases. + +The C method must return a boolean. This is used to tell +buffered subtests whether or not to send it events as they are being buffered. +See L for more information. + +The C and C methods are optional methods called that you +can implement if the format you're generating needs to handle these cases, for +example if you are generating XML and need close open tags. + +The C method is called when an event's C method returns +true, for example when a L has a C<'skip_all'> plan, or +when a L event is sent. The C method is passed +a single argument, the L object which triggered the terminate. + +The C method is always the last thing called on the formatter, I<< +except when C is called for a Bail event >>. It is passed the +following arguments: + +The C method should be true if the formatter supports directly +rendering table data from the C facets. This is a newer feature and many +older formatters may not support it. When not supported the formatter falls +back to rendering C instead of the C
data. + +The C method is used when constructing a root formatter. The default +is to just delegate to the regular C method, most formatters can ignore +this. + +=over 4 + +=item * The number of tests that were planned + +=item * The number of tests actually seen + +=item * The number of tests which failed + +=item * A boolean indicating whether or not the test suite passed + +=item * A boolean indicating whether or not this call is for a subtest + +=back + +The C method is called when C Initializes the root +hub for the first time. Most formatters will simply have this call C<< +$class->new >>, which is the default behavior. Some formatters however may want +to take extra action during construction of the root formatter, this is where +they can do that. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Hub/Interceptor/Terminator.pm ddclient-3.10.0/t/lib/Test2/Hub/Interceptor/Terminator.pm --- ddclient-3.9.1/t/lib/Test2/Hub/Interceptor/Terminator.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Hub/Interceptor/Terminator.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,51 @@ +package Test2::Hub::Interceptor::Terminator; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor::Terminator - Exception class used by +Test2::Hub::Interceptor + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Hub/Interceptor.pm ddclient-3.10.0/t/lib/Test2/Hub/Interceptor.pm --- ddclient-3.9.1/t/lib/Test2/Hub/Interceptor.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Hub/Interceptor.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,88 @@ +package Test2::Hub::Interceptor; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Test2::Hub::Interceptor::Terminator(); + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase; + +sub init { + my $self = shift; + $self->SUPER::init(); + $self->{+NESTED} = 0; +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + $self->{+NESTED} = 0; + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } +} + +sub terminate { + my $self = shift; + my ($code) = @_; + + eval { + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; + }; + my $err = $@; + + # Fallback + die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor - Hub used by interceptor to grab results. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Hub/Subtest.pm ddclient-3.10.0/t/lib/Test2/Hub/Subtest.pm --- ddclient-3.9.1/t/lib/Test2/Hub/Subtest.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Hub/Subtest.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,136 @@ +package Test2::Hub::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; +use Test2::Util qw/get_tid/; + +sub is_subtest { 1 } + +sub inherit { + my $self = shift; + my ($from) = @_; + + $self->SUPER::inherit($from); + + $self->{+NESTED} = $from->nested + 1; +} + +{ + # Legacy + no warnings 'once'; + *ID = \&Test2::Hub::HID; + *id = \&Test2::Hub::hid; + *set_id = \&Test2::Hub::set_hid; +} + +sub send { + my $self = shift; + my ($e) = @_; + + my $out = $self->SUPER::send($e); + + return $out if $self->{+MANUAL_SKIP_ALL}; + + my $f = $e->facet_data; + + my $plan = $f->{plan} or return $out; + return $out unless $plan->{skip}; + + my $trace = $f->{trace} or die "Missing Trace!"; + return $out unless $trace->{pid} != $self->pid + || $trace->{tid} != $self->tid; + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +sub terminate { + my $self = shift; + my ($code, $e, $f) = @_; + $self->set_exit_code($code); + + return if $self->{+MANUAL_SKIP_ALL}; + + $f ||= $e->facet_data; + + if(my $plan = $f->{plan}) { + my $trace = $f->{trace} or die "Missing Trace!"; + return if $plan->{skip} + && ($trace->{pid} != $$ || $trace->{tid} != get_tid); + } + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Subtest - Hub used by subtests + +=head1 DESCRIPTION + +Subtests make use of this hub to route events. + +=head1 TOGGLES + +=over 4 + +=item $bool = $hub->manual_skip_all + +=item $hub->set_manual_skip_all($bool) + +The default is false. + +Normally a skip-all plan event will cause a subtest to stop executing. This is +accomplished via C to a label inside the subtest code. Most of the +time this is perfectly fine. There are times however where this flow control +causes bad things to happen. + +This toggle lets you turn off the abort logic for the hub. When this is toggled +to true B are responsible for ensuring no additional events are generated. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Hub.pm ddclient-3.10.0/t/lib/Test2/Hub.pm --- ddclient-3.9.1/t/lib/Test2/Hub.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Hub.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,909 @@ +package Test2::Hub; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Carp qw/carp croak confess/; +use Test2::Util qw/get_tid gen_uid/; + +use Scalar::Util qw/weaken/; +use List::Util qw/first/; + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + pid tid hid ipc + nested buffered + no_ending + _filters + _pre_filters + _listeners + _follow_ups + _formatter + _context_acquire + _context_init + _context_release + + uuid + active + count + failed + ended + bailed_out + _passing + _plan + skip_reason +}; + +my $UUID_VIA; + +sub init { + my $self = shift; + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = gen_uid(); + + $UUID_VIA ||= Test2::API::_add_uuid_via_ref(); + $self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA; + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; + $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + if (my $formatter = delete $self->{formatter}) { + $self->format($formatter); + } + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + +sub is_subtest { 0 } + +sub _tb_reset { + my $self = shift; + + # Nothing to do + return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = gen_uid(); + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + +sub reset_state { + my $self = shift; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + delete $self->{+_PLAN}; + delete $self->{+ENDED}; + delete $self->{+BAILED_OUT}; + delete $self->{+SKIP_REASON}; +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + $self->{+NESTED} ||= 0; + + $self->{+_FORMATTER} = $from->{+_FORMATTER} + unless $self->{+_FORMATTER} || exists($params{formatter}); + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } + + if (my $ls = $from->{+_LISTENERS}) { + push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; + } + + if (my $pfs = $from->{+_PRE_FILTERS}) { + push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; + } + + if (my $fs = $from->{+_FILTERS}) { + push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; + } +} + +sub format { + my $self = shift; + + my $old = $self->{+_FORMATTER}; + ($self->{+_FORMATTER}) = @_ if @_; + + return $old; +} + +sub is_local { + my $self = shift; + return $$ == $self->{+PID} + && get_tid() == $self->{+TID}; +} + +sub listen { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "listen only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_LISTENERS}} => { %params, code => $sub }; + + $sub; # Intentional return. +} + +sub unlisten { + my $self = shift; + + carp "Useless removal of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + my %subs = map {$_ => $_} @_; + + @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; +} + +sub filter { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub unfilter { + my $self = shift; + carp "Useless removal of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + my %subs = map {$_ => $_} @_; + @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; +} + +sub pre_filter { + my $self = shift; + my ($sub, %params) = @_; + + croak "pre_filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub pre_unfilter { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; +} + +sub follow_up { + my $self = shift; + my ($sub) = @_; + + carp "Useless addition of a follow-up in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "follow_up only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FOLLOW_UPS}} => $sub; +} + +*add_context_aquire = \&add_context_acquire; +sub add_context_acquire { + my $self = shift; + my ($sub) = @_; + + croak "add_context_acquire only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; + + $sub; # Intentional return. +} + +*remove_context_aquire = \&remove_context_acquire; +sub remove_context_acquire { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}}; +} + +sub add_context_init { + my $self = shift; + my ($sub) = @_; + + croak "add_context_init only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_INIT}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_init { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; +} + +sub add_context_release { + my $self = shift; + my ($sub) = @_; + + croak "add_context_release only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_RELEASE}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_release { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; +} + +sub send { + my $self = shift; + my ($e) = @_; + + $e->eid; + + $e->add_hub( + { + details => ref($self), + + buffered => $self->{+BUFFERED}, + hid => $self->{+HID}, + nested => $self->{+NESTED}, + pid => $self->{+PID}, + tid => $self->{+TID}, + uuid => $self->{+UUID}, + + ipc => $self->{+IPC} ? 1 : 0, + } + ); + + $e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA; + + if ($self->{+_PRE_FILTERS}) { + for (@{$self->{+_PRE_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + my $ipc = $self->{+IPC} || return $self->process($e); + + if($e->global) { + $ipc->send($self->{+HID}, $e, 'GLOBAL'); + return $self->process($e); + } + + return $ipc->send($self->{+HID}, $e) + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + $self->process($e); +} + +sub process { + my $self = shift; + my ($e) = @_; + + if ($self->{+_FILTERS}) { + for (@{$self->{+_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + # Optimize the most common case + my $type = ref($e); + if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { + my $count = ++($self->{+COUNT}); + $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + } + + return $e; + } + + my $f = $e->facet_data; + + my $fail = 0; + $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; + $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}}; + $fail = 0 if $f->{amnesty}; + + $self->{+COUNT}++ if $f->{assert}; + $self->{+FAILED}++ if $fail && $f->{assert}; + $self->{+_PASSING} = 0 if $fail; + + my $code = $f->{control}->{terminate}; + my $count = $self->{+COUNT}; + + if (my $plan = $f->{plan}) { + if ($plan->{skip}) { + $self->plan('SKIP'); + $self->set_skip_reason($plan->{details} || 1); + $code ||= 0; + } + elsif ($plan->{none}) { + $self->plan('NO PLAN'); + } + else { + $self->plan($plan->{count}); + } + } + + $e->callback($self) if $f->{control}->{has_callback}; + + $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; + } + + if ($f->{control}->{halt}) { + $code ||= 255; + $self->set_bailed_out($e); + } + + if (defined $code) { + $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; + $self->terminate($code, $e, $f); + } + + return $e; +} + +sub terminate { + my $self = shift; + my ($code) = @_; + exit($code); +} + +sub cull { + my $self = shift; + + my $ipc = $self->{+IPC} || return; + return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); + + # No need to do IPC checks on culled events + $self->process($_) for $ipc->cull($self->{+HID}); +} + +sub finalize { + my $self = shift; + my ($trace, $do_plan) = @_; + + $self->cull(); + + my $plan = $self->{+_PLAN}; + my $count = $self->{+COUNT}; + my $failed = $self->{+FAILED}; + my $active = $self->{+ACTIVE}; + + # return if NOTHING was done. + unless ($active || $do_plan || defined($plan) || $count || $failed) { + $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; + return; + } + + unless ($self->{+ENDED}) { + if ($self->{+_FOLLOW_UPS}) { + $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; + } + + # These need to be refreshed now + $plan = $self->{+_PLAN}; + $count = $self->{+COUNT}; + $failed = $self->{+FAILED}; + + if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { + $self->send( + Test2::Event::Plan->new( + trace => $trace, + max => $count, + ) + ); + } + $plan = $self->{+_PLAN}; + } + + my $frame = $trace->frame; + if($self->{+ENDED}) { + my (undef, $ffile, $fline) = @{$self->{+ENDED}}; + my (undef, $sfile, $sline) = @$frame; + + die <<" EOT" +Test already ended! +First End: $ffile line $fline +Second End: $sfile line $sline + EOT + } + + $self->{+ENDED} = $frame; + my $pass = $self->is_passing(); # Generate the final boolean. + + $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; + + return $pass; +} + +sub is_passing { + my $self = shift; + + ($self->{+_PASSING}) = @_ if @_; + + # If we already failed just return 0. + my $pass = $self->{+_PASSING} or return 0; + return $self->{+_PASSING} = 0 if $self->{+FAILED}; + + my $count = $self->{+COUNT}; + my $ended = $self->{+ENDED}; + my $plan = $self->{+_PLAN}; + + return $pass if !$count && $plan && $plan =~ m/^SKIP$/; + + return $self->{+_PASSING} = 0 + if $ended && (!$count || !$plan); + + return $pass unless $plan && $plan =~ m/^\d+$/; + + if ($ended) { + return $self->{+_PASSING} = 0 if $count != $plan; + } + else { + return $self->{+_PASSING} = 0 if $count > $plan; + } + + return $pass; +} + +sub plan { + my $self = shift; + + return $self->{+_PLAN} unless @_; + + my ($plan) = @_; + + confess "You cannot unset the plan" + unless defined $plan; + + confess "You cannot change the plan" + if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; + + confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" + unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; + + $self->{+_PLAN} = $plan; +} + +sub check_plan { + my $self = shift; + + return undef unless $self->{+ENDED}; + my $plan = $self->{+_PLAN} || return undef; + + return 1 if $plan !~ m/^\d+$/; + + return 1 if $plan == $self->{+COUNT}; + return 0; +} + +sub DESTROY { + my $self = shift; + my $ipc = $self->{+IPC} || return; + return unless $$ == $self->{+PID}; + return unless get_tid() == $self->{+TID}; + $ipc->drop_hub($self->{+HID}); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub - The conduit through which all events flow. + +=head1 SYNOPSIS + + use Test2::Hub; + + my $hub = Test2::Hub->new(); + $hub->send(...); + +=head1 DESCRIPTION + +The hub is the place where all events get processed and handed off to the +formatter. The hub also tracks test state, and provides several hooks into the +event pipeline. + +=head1 COMMON TASKS + +=head2 SENDING EVENTS + + $hub->send($event) + +The C method is used to issue an event to the hub. This method will +handle thread/fork sync, filters, listeners, TAP output, etc. + +=head2 ALTERING OR REMOVING EVENTS + +You can use either C or C, depending on your +needs. Both have identical syntax, so only C is shown here. + + $hub->filter(sub { + my ($hub, $event) = @_; + + my $action = get_action($event); + + # No action should be taken + return $event if $action eq 'none'; + + # You want your filter to remove the event + return undef if $action eq 'delete'; + + if ($action eq 'do_it') { + my $new_event = copy_event($event); + ... Change your copy of the event ... + return $new_event; + } + + die "Should not happen"; + }); + +By default, filters are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the filter. You can change this behavior +with the C parameter: + + $hub->filter(sub { ... }, inherit => 1); + +=head2 LISTENING FOR EVENTS + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +By default listeners are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the listener. You can change this behavior +with the C parameter: + + $hub->listen(sub { ... }, inherit => 1); + + +=head2 POST-TEST BEHAVIORS + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, either when done_testing is called, or in +an END block. + +=head2 SETTING THE FORMATTER + +By default an instance of L is created and used. + + my $old = $hub->format(My::Formatter->new); + +Setting the formatter will REPLACE any existing formatter. You may set the +formatter to undef to prevent output. The old formatter will be returned if one +was already set. Only one formatter is allowed at a time. + +=head1 METHODS + +=over 4 + +=item $hub->send($event) + +This is where all events enter the hub for processing. + +=item $hub->process($event) + +This is called by send after it does any IPC handling. You can use this to +bypass the IPC process, but in general you should avoid using this. + +=item $old = $hub->format($formatter) + +Replace the existing formatter instance with a new one. Formatters must be +objects that implement a C<< $formatter->write($event) >> method. + +=item $sub = $hub->listen(sub { ... }, %optional_params) + +You can use this to record all events AFTER they have been sent to the +formatter. No changes made here will be meaningful, except possibly to other +listeners. + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +Normally listeners are not inherited by child hubs such as subtests. You can +add the C<< inherit => 1 >> parameter to allow a listener to be inherited. + +=item $hub->unlisten($sub) + +You can use this to remove a listen callback. You must pass in the coderef +returned by the C method. + +=item $sub = $hub->filter(sub { ... }, %optional_params) + +=item $sub = $hub->pre_filter(sub { ... }, %optional_params) + +These can be used to add filters. Filters can modify, replace, or remove events +before anything else can see them. + + $hub->filter( + sub { + my ($hub, $event) = @_; + + return $event; # No Changes + return; # Remove the event + + # Or you can modify an event before returning it. + $event->modify; + return $event; + } + ); + +If you are not using threads, forking, or IPC then the only difference between +a C and a C is that C subs run first. When you +are using threads, forking, or IPC, pre_filters happen to events before they +are sent to their destination proc/thread, ordinary filters happen only in the +destination hub/thread. + +You cannot add a regular filter to a hub if the hub was created in another +process or thread. You can always add a pre_filter. + +=item $hub->unfilter($sub) + +=item $hub->pre_unfilter($sub) + +These can be used to remove filters and pre_filters. The C<$sub> argument is +the reference returned by C or C. + +=item $hub->follow_op(sub { ... }) + +Use this to add behaviors that are called just before the hub is finalized. The +only argument to your codeblock will be a L instance. + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, ether when done_testing is called, or in +an END block. + +=item $sub = $hub->add_context_acquire(sub { ... }); + +Add a callback that will be called every time someone tries to acquire a +context. It gets a single argument, a reference of the hash of parameters +being used the construct the context. This is your chance to change the +parameters by directly altering the hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_acquire($sub); + +This can be used to remove a context acquire hook. + +=item $sub = $hub->add_context_init(sub { ... }); + +This allows you to add callbacks that will trigger every time a new context is +created for the hub. The only argument to the sub will be the +L instance that was created. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_init($sub); + +This can be used to remove a context init hook. + +=item $sub = $hub->add_context_release(sub { ... }); + +This allows you to add callbacks that will trigger every time a context for +this hub is released. The only argument to the sub will be the +L instance that was released. These will run in reverse +order. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_release($sub); + +This can be used to remove a context release hook. + +=item $hub->cull() + +Cull any IPC events (and process them). + +=item $pid = $hub->pid() + +Get the process id under which the hub was created. + +=item $tid = $hub->tid() + +Get the thread id under which the hub was created. + +=item $hud = $hub->hid() + +Get the identifier string of the hub. + +=item $uuid = $hub->uuid() + +If UUID tagging is enabled (see L) then the hub will have a UUID. + +=item $ipc = $hub->ipc() + +Get the IPC object used by the hub. + +=item $hub->set_no_ending($bool) + +=item $bool = $hub->no_ending + +This can be used to disable auto-ending behavior for a hub. The auto-ending +behavior is triggered by an end block and is used to cull IPC events, and +output the final plan if the plan was 'NO PLAN'. + +=item $bool = $hub->active + +=item $hub->set_active($bool) + +These are used to get/set the 'active' attribute. When true this attribute will +force C<< hub->finalize() >> to take action even if there is no plan, and no +tests have been run. This flag is useful for plugins that add follow-up +behaviors that need to run even if no events are seen. + +=back + +=head2 STATE METHODS + +=over 4 + +=item $hub->reset_state() + +Reset all state to the start. This sets the test count to 0, clears the plan, +removes the failures, etc. + +=item $num = $hub->count + +Get the number of tests that have been run. + +=item $num = $hub->failed + +Get the number of failures (Not all failures come from a test fail, so this +number can be larger than the count). + +=item $bool = $hub->ended + +True if the testing has ended. This MAY return the stack frame of the tool that +ended the test, but that is not guaranteed. + +=item $bool = $hub->is_passing + +=item $hub->is_passing($bool) + +Check if the overall test run is a failure. Can also be used to set the +pass/fail status. + +=item $hub->plan($plan) + +=item $plan = $hub->plan + +Get or set the plan. The plan must be an integer larger than 0, the string +'NO PLAN', or the string 'SKIP'. + +=item $bool = $hub->check_plan + +Check if the plan and counts match, but only if the tests have ended. If tests +have not ended this will return undef, otherwise it will be a true/false. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/IPC/Driver/Files.pm ddclient-3.10.0/t/lib/Test2/IPC/Driver/Files.pm --- ddclient-3.9.1/t/lib/Test2/IPC/Driver/Files.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/IPC/Driver/Files.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,503 @@ +package Test2::IPC::Driver::Files; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } + +use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals}; + +use Scalar::Util qw/blessed/; +use File::Temp(); +use Storable(); +use File::Spec(); +use POSIX(); + +use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/; +use Test2::API qw/test2_ipc_set_pending/; + +sub is_viable { 1 } + +sub init { + my $self = shift; + + my $tmpdir = File::Temp::tempdir( + $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", + CLEANUP => 0, + TMPDIR => 1, + ); + + $self->abort_trace("Could not get a temp dir") unless $tmpdir; + + $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); + + print STDERR "\nIPC Temp Dir: $tmpdir\n\n" + if $ENV{T2_KEEP_TEMPDIR}; + + $self->{+EVENT_IDS} = {}; + $self->{+READ_IDS} = {}; + $self->{+TIMEOUTS} = {}; + + $self->{+TID} = get_tid(); + $self->{+PID} = $$; + + $self->{+GLOBALS} = {}; + + return $self; +} + +sub hub_file { + my $self = shift; + my ($hid) = @_; + my $tdir = $self->{+TEMPDIR}; + return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); +} + +sub event_file { + my $self = shift; + my ($hid, $e) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); + + $self->abort("'$e' is not an event object!") + unless $type->isa('Test2::Event'); + + my $tid = get_tid(); + my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1; + + my @type = split '::', $type; + my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type); + + return File::Spec->catfile($tempdir, $name); +} + +sub add_hub { + my $self = shift; + my ($hid) = @_; + + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' already exists") + if -e $hfile; + + open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); + print $fh "$$\n" . get_tid() . "\n"; + close($fh); +} + +sub drop_hub { + my $self = shift; + my ($hid) = @_; + + my $tdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' does not exist") + unless -e $hfile; + + open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); + my ($pid, $tid) = <$fh>; + close($fh); + + $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") + unless $pid == $$; + + $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) + unless get_tid() == $tid; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); + $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok + } + else { + my ($ok, $err) = do_unlink($hfile); + $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok + } + + opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); + + my %bad; + for my $file (readdir($dh)) { + next if $file =~ m{\.complete$}; + next unless $file =~ m{^$hid}; + + eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file"; + } + closedir($dh); + + return unless keys %bad; + + my $data; + my $ok = eval { + require JSON::PP; + local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } }; + my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed; + $data = $json->encode(\%bad); + 1; + }; + $ok ||= eval { + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + $data = Data::Dumper::Dumper(\%bad); + 1; + }; + + $data = "Could not dump data... sorry." unless defined $data; + + $self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n"); +} + +sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + my $dest = $global ? 'GLOBAL' : $hid; + + $self->abort(<<" EOT") unless $global || -f $hfile; +hub '$hid' is not available, failed to send event! + +There was an attempt to send an event to a hub in a parent process or thread, +but that hub appears to be gone. This can happen if you fork, or start a new +thread from inside subtest, and the parent finishes the subtest before the +child returns. + +This can also happen if the parent process is done testing before the child +finishes. Test2 normally waits automatically in the root process, but will not +do so if Test::Builder is loaded for legacy reasons. + EOT + + my $file = $self->event_file($dest, $e); + my $ready = File::Spec->canonpath("$file.ready"); + + if ($global) { + my $name = $ready; + $name =~ s{^.*(GLOBAL)}{GLOBAL}; + $self->{+GLOBALS}->{$hid}->{$name}++; + } + + # Write and rename the file. + my ($ren_ok, $ren_err); + my ($ok, $err) = try_sig_mask { + Storable::store($e, $file); + ($ren_ok, $ren_err) = do_rename("$file", $ready); + }; + + if ($ok) { + $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; + test2_ipc_set_pending($file); + } + else { + my $src_file = __FILE__; + $err =~ s{ at \Q$src_file\E.*$}{}; + chomp($err); + my $tid = get_tid(); + my $trace = $e->trace->debug; + my $type = blessed($e); + + $self->abort(<<" EOT"); + +******************************************************************************* +There was an error writing an event: +Destination: $dest +Origin PID: $$ +Origin TID: $tid +Event Type: $type +Event Trace: $trace +File Name: $file +Ready Name: $ready +Error: $err +******************************************************************************* + + EOT + } + + return 1; +} + +sub driver_abort { + my $self = shift; + my ($msg) = @_; + + local ($@, $!, $?, $^E); + eval { + my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + open(my $fh, '>>', $abort) or die "Could not open abort file: $!"; + print $fh $msg, "\n"; + close($fh) or die "Could not close abort file: $!"; + 1; + } or warn $@; +} + +sub cull { + my $self = shift; + my ($hid) = @_; + + my $tempdir = $self->{+TEMPDIR}; + + opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); + + my $read = $self->{+READ_IDS}; + my $timeouts = $self->{+TIMEOUTS}; + + my @out; + for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { + unless ($info->{global}) { + my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1; + + $timeouts->{$info->{file}} ||= time; + + if ($next != $info->{eid}) { + # Wait up to N seconds for missing events + next unless 5 < time - $timeouts->{$info->{file}}; + $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}."); + } + + $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1; + } + + my $full = $info->{full_path}; + my $obj = $self->read_event_file($full); + push @out => $obj; + + # Do not remove global events + next if $info->{global}; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my $complete = File::Spec->canonpath("$full.complete"); + my ($ok, $err) = do_rename($full, $complete); + $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; + } + else { + my ($ok, $err) = do_unlink("$full"); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + } + } + + closedir($dh); + return @out; +} + +sub parse_event_filename { + my $self = shift; + my ($file) = @_; + + # The || is to force 0 in false + my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); + my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); + + my @parts = split ipc_separator, $file; + my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4)); + my ($pid, $tid, $eid) = splice(@parts, 0, 3); + my $type = join '::' => @parts; + + return { + file => $file, + ready => $ready, + complete => $complete, + global => $global, + type => $type, + hid => $hid, + pid => $pid, + tid => $tid, + eid => $eid, + }; +} + +sub should_read_event { + my $self = shift; + my ($hid, $file) = @_; + + return if substr($file, 0, 1) eq '.'; + return if substr($file, 0, 3) eq 'HUB'; + CORE::exit(255) if $file eq 'ABORT'; + + my $parsed = $self->parse_event_filename($file); + + return if $parsed->{complete}; + return unless $parsed->{ready}; + return unless $parsed->{global} || $parsed->{hid} eq $hid; + + return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; + + # Untaint the path. + my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); + ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; + + $parsed->{full_path} = $full; + + return $parsed; +} + +sub cmp_events { + # Globals first + return -1 if $a->{global} && !$b->{global}; + return 1 if $b->{global} && !$a->{global}; + + return $a->{pid} <=> $b->{pid} + || $a->{tid} <=> $b->{tid} + || $a->{eid} <=> $b->{eid}; +} + +sub read_event_file { + my $self = shift; + my ($file) = @_; + + my $obj = Storable::retrieve($file); + $self->abort("Got an unblessed object: '$obj'") + unless blessed($obj); + + unless ($obj->isa('Test2::Event')) { + my $pkg = blessed($obj); + my $mod_file = pkg_to_file($pkg); + my ($ok, $err) = try { require $mod_file }; + + $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") + unless $ok; + + $self->abort("'$obj' is not a 'Test2::Event' object") + unless $obj->isa('Test2::Event'); + } + + return $obj; +} + +sub waiting { + my $self = shift; + require Test2::Event::Waiting; + $self->send( + GLOBAL => Test2::Event::Waiting->new( + trace => Test2::EventFacet::Trace->new(frame => [caller()]), + ), + 'GLOBAL' + ); + return; +} + +sub DESTROY { + my $self = shift; + + return unless defined $self->pid; + return unless defined $self->tid; + + return unless $$ == $self->pid; + return unless get_tid() == $self->tid; + + my $tempdir = $self->{+TEMPDIR}; + + my $aborted = 0; + my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + if (-e $abort_file) { + $aborted = 1; + my ($ok, $err) = do_unlink($abort_file); + warn $err unless $ok; + } + + opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + next if $file =~ m/\.complete$/; + my $full = File::Spec->catfile($tempdir, $file); + + my $sep = ipc_separator; + if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) { + $full =~ m/^(.*)$/; + $full = $1; # Untaint it + next if $ENV{T2_KEEP_TEMPDIR}; + my ($ok, $err) = do_unlink($full); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + next; + } + + $self->abort("Leftover files in the directory ($full)!\n"); + } + closedir($dh); + + if ($ENV{T2_KEEP_TEMPDIR}) { + print STDERR "# Not removing temp dir: $tempdir\n"; + return; + } + + my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + unlink($abort) if -e $abort; + rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver::Files - Temp dir + Files concurrency model. + +=head1 DESCRIPTION + +This is the default, and fallback concurrency model for L. This +sends events between processes and threads using serialized files in a +temporary directory. This is not particularly fast, but it works everywhere. + +=head1 SYNOPSIS + + use Test2::IPC::Driver::Files; + + # IPC is now enabled + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +=item T2_KEEP_TEMPDIR=0 + +When true, the tempdir used by the IPC driver will not be deleted when the test +is done. + +=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' + +This can be used to set the template for the IPC temp dir. The template should +follow template specifications from L. + +=back + +=head1 SEE ALSO + +See L for methods. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/IPC/Driver.pm ddclient-3.10.0/t/lib/Test2/IPC/Driver.pm --- ddclient-3.9.1/t/lib/Test2/IPC/Driver.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/IPC/Driver.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,287 @@ +package Test2::IPC::Driver; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Carp qw/confess/; +use Test2::Util::HashBase qw{no_fatal no_bail}; + +use Test2::API qw/test2_ipc_add_driver/; + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + test2_ipc_add_driver($class); +} + +sub pending { -1 } +sub set_pending { -1 } + +for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { + no strict 'refs'; + *$meth = sub { + my $thing = shift; + confess "'$thing' did not define the required method '$meth'." + }; +} + +# Print the error and call exit. We are not using 'die' cause this is a +# catastrophic error that should never be caught. If we get here it +# means some serious shit has happened in a child process, the only way +# to inform the parent may be to exit false. + +sub abort { + my $self = shift; + chomp(my ($msg) = @_); + + $self->driver_abort($msg) if $self->can('driver_abort'); + + print STDERR "IPC Fatal Error: $msg\n"; + print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; + + CORE::exit(255) unless $self->no_fatal; +} + +sub abort_trace { + my $self = shift; + my ($msg) = @_; + # Older versions of Carp do not export longmess() function, so it needs to be called with package name + $self->abort(Carp::longmess($msg)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver - Base class for Test2 IPC drivers. + +=head1 SYNOPSIS + + package Test2::IPC::Driver::MyDriver; + + use base 'Test2::IPC::Driver'; + + ... + +=head1 METHODS + +=over 4 + +=item $self->abort($msg) + +If an IPC encounters a fatal error it should use this. This will print the +message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will +forcefully exit 255. IPC errors may occur in threads or processes other than +the main one, this method provides the best chance of the harness noticing the +error. + +=item $self->abort_trace($msg) + +This is the same as C<< $ipc->abort($msg) >> except that it uses +C to add a stack trace to the message. + +=back + +=head1 LOADING DRIVERS + +Test2::IPC::Driver has an C method. All drivers inherit this import +method. This import method registers the driver. + +In most cases you just need to load the desired IPC driver to make it work. You +should load this driver as early as possible. A warning will be issued if you +load it too late for it to be effective. + + use Test2::IPC::Driver::MyDriver; + ... + +=head1 WRITING DRIVERS + + package Test2::IPC::Driver::MyDriver; + use strict; + use warnings; + + use base 'Test2::IPC::Driver'; + + sub is_viable { + return 0 if $^O eq 'win32'; # Will not work on windows. + return 1; + } + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + + sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + ... # Send the event to the proper hub. + + # This may notify other procs/threads that there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + + 1; + +=head2 METHODS SUBCLASSES MUST IMPLEMENT + +=over 4 + +=item $ipc->is_viable + +This should return true if the driver works in the current environment. This +should return false if it does not. This is a CLASS method. + +=item $ipc->add_hub($hid) + +This is used to alert the driver that a new hub is expecting events. The driver +should keep track of the process and thread ids, the hub should only be dropped +by the proc+thread that started it. + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + +=item $ipc->drop_hub($hid) + +This is used to alert the driver that a hub is no longer accepting events. The +driver should keep track of the process and thread ids, the hub should only be +dropped by the proc+thread that started it (This is the drivers responsibility +to enforce). + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + +=item $ipc->send($hid, $event); + +=item $ipc->send($hid, $event, $global); + +Used to send events from the current process/thread to the specified hub in its +process+thread. + + sub send { + my $self = shift; + my ($hid, $e) = @_; + + ... # Send the event to the proper hub. + + # This may notify other procs/threads that there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + +If C<$global> is true then the driver should send the event to all hubs in all +processes and threads. + +=item @events = $ipc->cull($hid) + +Used to collect events that have been sent to the specified hub. + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + +=item $ipc->waiting() + +This is called in the parent process when it is complete and waiting for all +child processes and threads to complete. + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + +=back + +=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE + +=over 4 + +=item $ipc->driver_abort($msg) + +This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your +chance to cleanup when an abort happens. You cannot prevent the abort, but you +can gracefully except it. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/IPC.pm ddclient-3.10.0/t/lib/Test2/IPC.pm --- ddclient-3.9.1/t/lib/Test2/IPC.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/IPC.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,160 @@ +package Test2::IPC; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Test2::API::Instance; +use Test2::Util qw/get_tid/; +use Test2::API qw{ + test2_in_preload + test2_init_done + test2_ipc + test2_has_ipc + test2_ipc_enable_polling + test2_pid + test2_stack + test2_tid + context +}; + +# Make sure stuff is finalized before anyone tried to fork or start a new thread. +{ + # Avoid warnings if things are loaded at run-time + no warnings 'void'; + INIT { + use warnings 'void'; + context()->release() unless test2_in_preload(); + } +} + +use Carp qw/confess/; + +our @EXPORT_OK = qw/cull/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub unimport { Test2::API::test2_ipc_disable() } + +sub import { + goto &Exporter::import if test2_has_ipc || !test2_init_done(); + + confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); + confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; + confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); + + Test2::API::_set_ipc(_make_ipc()); + apply_ipc(test2_stack()); + + goto &Exporter::import; +} + +sub _make_ipc { + # Find a driver + my ($driver) = Test2::API::test2_ipc_drivers(); + unless ($driver) { + require Test2::IPC::Driver::Files; + $driver = 'Test2::IPC::Driver::Files'; + } + + return $driver->new(); +} + +sub apply_ipc { + my $stack = shift; + + my ($root) = @$stack; + + return unless $root; + + confess "Cannot add IPC in a child process" if $root->pid != $$; + confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); + + my $ipc = $root->ipc || test2_ipc() || _make_ipc(); + + # Add the IPC to all hubs + for my $hub (@$stack) { + my $has = $hub->ipc; + confess "IPC Mismatch!" if $has && $has != $ipc; + next if $has; + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + + test2_ipc_enable_polling(); + + return $ipc; +} + +sub cull { + my $ctx = context(); + $ctx->hub->cull; + $ctx->release; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC - Turn on IPC for threading or forking support. + +=head1 SYNOPSIS + +You should C as early as possible in your test file. If you +import this module after API initialization it will attempt to retrofit IPC +onto the existing hubs. + +=head2 DISABLING IT + +You can use C to disable IPC for good. You can also use the +T2_NO_IPC env var. + +=head1 EXPORTS + +All exports are optional. + +=over 4 + +=item cull() + +Cull allows you to collect results from other processes or threads on demand. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Tools/Tiny.pm ddclient-3.10.0/t/lib/Test2/Tools/Tiny.pm --- ddclient-3.9.1/t/lib/Test2/Tools/Tiny.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Tools/Tiny.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,435 @@ +package Test2::Tools::Tiny; +use strict; +use warnings; + +BEGIN { + if ($] lt "5.008") { + require Test::Builder::IO::Scalar; + } +} + +use Scalar::Util qw/blessed/; + +use Test2::Util qw/try/; +use Test2::API qw/context run_subtest test2_stack/; + +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +our $VERSION = '1.302175'; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } +our @EXPORT = qw{ + ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing + warnings exception tests capture +}; + +sub ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +sub is($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" eq "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 0; + } + else { # Both are undef + $bool = 1; + } + + return $ctx->pass_and_release($name) if $bool; + + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + + return $ctx->fail_and_release($name, @diag); +} + +sub isnt($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" ne "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 1; + } + else { # Both are undef + $bool = 0; + } + + return $ctx->pass_and_release($name) if $bool; + + unshift @diag => "Strings are the same (they should not be)" + unless $bool; + + return $ctx->fail_and_release($name, @diag); +} + +sub like($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" =~ $pattern; + unshift @diag => ( + "Value: $thing", + "Does not match: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +sub unlike($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" !~ $pattern; + unshift @diag => ( + "Unexpected pattern match (it should not match)", + "Value: $thing", + "Matches: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +sub is_deeply($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + no warnings 'once'; + require Data::Dumper; + + # Otherwise numbers might be unquoted + local $Data::Dumper::Useperl = 1; + + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Freezer = 'XXX'; + local *UNIVERSAL::XXX = sub { + my ($thing) = @_; + if (ref($thing)) { + $thing = {%$thing} if "$thing" =~ m/=HASH/; + $thing = [@$thing] if "$thing" =~ m/=ARRAY/; + $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; + } + $_[0] = $thing; + }; + + my $g = Data::Dumper::Dumper($got); + my $w = Data::Dumper::Dumper($want); + + my $bool = $g eq $w; + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, $g, $w, @diag); +} + +sub diag { + my $ctx = context(); + $ctx->diag(join '', @_); + $ctx->release; +} + +sub note { + my $ctx = context(); + $ctx->note(join '', @_); + $ctx->release; +} + +sub skip_all { + my ($reason) = @_; + my $ctx = context(); + $ctx->plan(0, SKIP => $reason); + $ctx->release if $ctx; +} + +sub todo { + my ($reason, $sub) = @_; + my $ctx = context(); + + # This code is mostly copied from Test2::Todo in the Test2-Suite + # distribution. + my $hub = test2_stack->top; + my $filter = $hub->pre_filter( + sub { + my ($active_hub, $event) = @_; + if ($active_hub == $hub) { + $event->set_todo($reason) if $event->can('set_todo'); + $event->add_amnesty({tag => 'TODO', details => $reason}); + } + else { + $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1}); + } + return $event; + }, + inherit => 1, + todo => $reason, + ); + $sub->(); + $hub->pre_unfilter($filter); + + $ctx->release if $ctx; +} + +sub plan { + my ($max) = @_; + my $ctx = context(); + $ctx->plan($max); + $ctx->release; +} + +sub done_testing { + my $ctx = context(); + $ctx->done_testing; + $ctx->release; +} + +sub warnings(&) { + my $code = shift; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return \@warnings; +} + +sub exception(&) { + my $code = shift; + local ($@, $!, $SIG{__DIE__}); + my $ok = eval { $code->(); 1 }; + my $error = $@ || 'SQUASHED ERROR'; + return $ok ? undef : $error; +} + +sub tests { + my ($name, $code) = @_; + my $ctx = context(); + + my $be = caller->can('before_each'); + + $be->($name) if $be; + + my $bool = run_subtest($name, $code, 1); + + $ctx->release; + + return $bool; +} + +sub capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my $handles = test2_stack->top->format->handles; + my ($ok, $e); + { + my ($out_fh, $err_fh); + + ($ok, $e) = try { + # Scalar refs as filehandles were added in 5.8. + if ($] ge "5.008") { + open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + } + # Emulate scalar ref filehandles with a tie. + else { + $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT"; + $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR"; + } + + test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); + + $code->(); + }; + } + test2_stack->top->format->set_handles($handles); + + die $e unless $ok; + + $err =~ s/ $/_/mg; + $out =~ s/ $/_/mg; + + return { + STDOUT => $out, + STDERR => $err, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use +L. + +=head1 DESCRIPTION + +You should really look at L. This package is some very basic +essential tools implemented using L. This exists only so that L +and other tools required by L can be tested. This is the package +L uses to test itself. + +=head1 USE Test2::Suite INSTEAD + +Use L if at all possible. + +=head1 EXPORTS + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +Run a simple assertion. + +=item is($got, $want, $name) + +=item is($got, $want, $name, @diag) + +Assert that 2 strings are the same. + +=item isnt($got, $do_not_want, $name) + +=item isnt($got, $do_not_want, $name, @diag) + +Assert that 2 strings are not the same. + +=item like($got, $regex, $name) + +=item like($got, $regex, $name, @diag) + +Check that the input string matches the regex. + +=item unlike($got, $regex, $name) + +=item unlike($got, $regex, $name, @diag) + +Check that the input string does not match the regex. + +=item is_deeply($got, $want, $name) + +=item is_deeply($got, $want, $name, @diag) + +Check 2 data structures. Please note that this is a I implementation that +compares the output of L against both structures. + +=item diag($msg) + +Issue a diagnostics message to STDERR. + +=item note($msg) + +Issue a diagnostics message to STDOUT. + +=item skip_all($reason) + +Skip all tests. + +=item todo $reason => sub { ... } + +Run a block in TODO mode. + +=item plan($count) + +Set the plan. + +=item done_testing() + +Set the plan to the current test count. + +=item $warnings = warnings { ... } + +Capture an arrayref of warnings from the block. + +=item $exception = exception { ... } + +Capture an exception. + +=item tests $name => sub { ... } + +Run a subtest. + +=item $output = capture { ... } + +Capture STDOUT and STDERR output. + +Result looks like this: + + { + STDOUT => "...", + STDERR => "...", + } + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Util/ExternalMeta.pm ddclient-3.10.0/t/lib/Test2/Util/ExternalMeta.pm --- ddclient-3.9.1/t/lib/Test2/Util/ExternalMeta.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Util/ExternalMeta.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,182 @@ +package Test2::Util::ExternalMeta; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +use Carp qw/croak/; + +sub META_KEY() { '_meta' } + +our @EXPORT = qw/meta set_meta get_meta delete_meta/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub set_meta { + my $self = shift; + my ($key, $value) = @_; + + validate_key($key); + + $self->{+META_KEY} ||= {}; + $self->{+META_KEY}->{$key} = $value; +} + +sub get_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + return $meta->{$key}; +} + +sub delete_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + delete $meta->{$key}; +} + +sub meta { + my $self = shift; + my ($key, $default) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY}; + return undef unless $meta || defined($default); + + unless($meta) { + $meta = {}; + $self->{+META_KEY} = $meta; + } + + $meta->{$key} = $default + if defined($default) && !defined($meta->{$key}); + + return $meta->{$key}; +} + +sub validate_key { + my $key = shift; + + return if $key && !ref($key); + + my $render_key = defined($key) ? "'$key'" : 'undef'; + croak "Invalid META key: $render_key, keys must be true, and may not be references"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data +to your instances. + +=head1 DESCRIPTION + +This package lets you define a clear, and consistent way to allow third party +tools to attach meta-data to your instances. If your object consumes this +package, and imports its methods, then third party meta-data has a safe place +to live. + +=head1 SYNOPSIS + + package My::Object; + use strict; + use warnings; + + use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; + + ... + +Now to use it: + + my $inst = My::Object->new; + + $inst->set_meta(foo => 'bar'); + my $val = $inst->get_meta('foo'); + +=head1 WHERE IS THE DATA STORED? + +This package assumes your instances are blessed hashrefs, it will not work if +that is not true. It will store all meta-data in the C<_meta> key on your +objects hash. If your object makes use of the C<_meta> key in its underlying +hash, then there is a conflict and you cannot use this package. + +=head1 EXPORTS + +=over 4 + +=item $val = $obj->meta($key) + +=item $val = $obj->meta($key, $default) + +This will get the value for a specified meta C<$key>. Normally this will return +C when there is no value for the C<$key>, however you can specify a +C<$default> value to set when no value is already set. + +=item $val = $obj->get_meta($key) + +This will get the value for a specified meta C<$key>. This does not have the +C<$default> overhead that C does. + +=item $val = $obj->delete_meta($key) + +This will remove the value of a specified meta C<$key>. The old C<$val> will be +returned. + +=item $obj->set_meta($key, $val) + +Set the value of a specified meta C<$key>. + +=back + +=head1 META-KEY RESTRICTIONS + +Meta keys must be defined, and must be true when used as a boolean. Keys may +not be references. You are free to stringify a reference C<"$ref"> for use as a +key, but this package will not stringify it for you. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Util/Facets2Legacy.pm ddclient-3.10.0/t/lib/Test2/Util/Facets2Legacy.pm --- ddclient-3.9.1/t/lib/Test2/Util/Facets2Legacy.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Util/Facets2Legacy.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,299 @@ +package Test2::Util::Facets2Legacy; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use base 'Exporter'; +our @EXPORT_OK = qw{ + causes_fail + diagnostics + global + increments_count + no_display + sets_plan + subtest_id + summary + terminate + uuid +}; +our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); + +our $CYCLE_DETECT = 0; +sub _get_facet_data { + my $in = shift; + + if (blessed($in) && $in->isa('Test2::Event')) { + confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" + if $CYCLE_DETECT; + + local $CYCLE_DETECT = 1; + return $in->facet_data; + } + + return $in if ref($in) eq 'HASH'; + + croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; +} + +sub causes_fail { + my $facet_data = _get_facet_data(shift @_); + + return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; + + if (my $control = $facet_data->{control}) { + return 1 if $control->{halt}; + return 1 if $control->{terminate}; + } + + return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; + return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; + return 0; +} + +sub diagnostics { + my $facet_data = _get_facet_data(shift @_); + return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; + return 0 unless $facet_data->{info} && @{$facet_data->{info}}; + return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; +} + +sub global { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{control}; + return $facet_data->{control}->{global}; +} + +sub increments_count { + my $facet_data = _get_facet_data(shift @_); + return $facet_data->{assert} ? 1 : 0; +} + +sub no_display { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{about}; + return $facet_data->{about}->{no_display}; +} + +sub sets_plan { + my $facet_data = _get_facet_data(shift @_); + my $plan = $facet_data->{plan} or return; + my @out = ($plan->{count} || 0); + + if ($plan->{skip}) { + push @out => 'SKIP'; + push @out => $plan->{details} if defined $plan->{details}; + } + elsif ($plan->{none}) { + push @out => 'NO PLAN' + } + + return @out; +} + +sub subtest_id { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{parent}; + return $facet_data->{parent}->{hid}; +} + +sub summary { + my $facet_data = _get_facet_data(shift @_); + return '' unless $facet_data->{about} && $facet_data->{about}->{details}; + return $facet_data->{about}->{details}; +} + +sub terminate { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{control}; + return $facet_data->{control}->{terminate}; +} + +sub uuid { + my $in = shift; + + if ($CYCLE_DETECT) { + if (blessed($in) && $in->isa('Test2::Event')) { + my $meth = $in->can('uuid'); + $meth = $in->can('SUPER::uuid') if $meth == \&uuid; + my $uuid = $in->$meth if $meth && $meth != \&uuid; + return $uuid if $uuid; + } + + return undef; + } + + my $facet_data = _get_facet_data($in); + return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid}; + + return undef; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Facets2Legacy - Convert facet data to the legacy event API. + +=head1 DESCRIPTION + +This module exports several subroutines from the older event API (see +L). These subroutines can be used as methods on any object that +provides a custom C method. These subroutines can also be used as +functions that take a facet data hashref as arguments. + +=head1 SYNOPSIS + +=head2 AS METHODS + + package My::Event; + + use Test2::Util::Facets2Legacy ':ALL'; + + sub facet_data { return { ... } } + +Then to use it: + + my $e = My::Event->new(...); + + my $causes_fail = $e->causes_fail; + my $summary = $e->summary; + .... + +=head2 AS FUNCTIONS + + use Test2::Util::Facets2Legacy ':ALL'; + + my $f = { + assert => { ... }, + info => [{...}, ...], + control => {...}, + ... + }; + + my $causes_fail = causes_fail($f); + my $summary = summary($f); + +=head1 NOTE ON CYCLES + +When used as methods, all these subroutines call C<< $e->facet_data() >>. The +default C method in L relies on the legacy methods +this module emulates in order to work. As a result of this it is very easy to +create infinite recursion bugs. + +These methods have cycle detection and will throw an exception early if a cycle +is detected. C is currently the only subroutine in this library that +has a fallback behavior when cycles are detected. + +=head1 EXPORTS + +Nothing is exported by default. You must specify which methods to import, or +use the ':ALL' tag. + +=over 4 + +=item $bool = $e->causes_fail() + +=item $bool = causes_fail($f) + +Check if the event or facets result in a failing state. + +=item $bool = $e->diagnostics() + +=item $bool = diagnostics($f) + +Check if the event or facets contain any diagnostics information. + +=item $bool = $e->global() + +=item $bool = global($f) + +Check if the event or facets need to be globally processed. + +=item $bool = $e->increments_count() + +=item $bool = increments_count($f) + +Check if the event or facets make an assertion. + +=item $bool = $e->no_display() + +=item $bool = no_display($f) + +Check if the event or facets should be rendered or hidden. + +=item ($max, $directive, $reason) = $e->sets_plan() + +=item ($max, $directive, $reason) = sets_plan($f) + +Check if the event or facets set a plan, and return the plan details. + +=item $id = $e->subtest_id() + +=item $id = subtest_id($f) + +Get the subtest id, if any. + +=item $string = $e->summary() + +=item $string = summary($f) + +Get the summary of the event or facets hash, if any. + +=item $undef_or_int = $e->terminate() + +=item $undef_or_int = terminate($f) + +Check if the event or facets should result in process termination, if so the +exit code is returned (which could be 0). undef is returned if no termination +is requested. + +=item $uuid = $e->uuid() + +=item $uuid = uuid($f) + +Get the UUID of the facets or event. + +B This will fall back to C<< $e->SUPER::uuid() >> if a cycle is +detected and an event is used as the argument. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Util/HashBase.pm ddclient-3.10.0/t/lib/Test2/Util/HashBase.pm --- ddclient-3.9.1/t/lib/Test2/Util/HashBase.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Util/HashBase.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,473 @@ +package Test2::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Util::HashBase::HB_VERSION = '0.009'; + *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, +); + +sub import { + my $class = shift; + my $into = caller; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION; + $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= []; + my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; + + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; + push @$attr_list => $x; + my ($sub, $attr) = (uc $x, $x); + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; + + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Util::HashBase qw/foo -bar ^baz ban +boo/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Util::HashBase qw/bub/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BUB} ||= 'bub'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); + + # Readers! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + # '{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C method, as well as generating accessors you request. +Generated accessors will be getters, C setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L. This file was generated using +the +C +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C if there is already a C method in your +packages inheritance chain. + +B you just have to +declare it before loading L. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +B Test2::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +To generate accessors you list them when using the module: + + use Test2::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C field. + +=item set_foo() + +Setter, used to set the value of the C field. + +=item FOO() + +Constant, returns the field C's key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head2 READ ONLY + + use Test2::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + +=head2 NO SETTER + + use Test2::Util::HashBase qw/ method is defined at all. + +=head2 NO READER + + use Test2::Util::HashBase qw/>foo/; + +Only gives you a write (C), no C method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C constant. + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Util::HashBase class. + +=over 4 + +=item @list = Test2::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2017 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Util/Trace.pm ddclient-3.10.0/t/lib/Test2/Util/Trace.pm --- ddclient-3.9.1/t/lib/Test2/Util/Trace.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Util/Trace.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,54 @@ +package Test2::Util::Trace; +require Test2::EventFacet::Trace; +@ISA = ('Test2::EventFacet::Trace'); + +our $VERSION = '1.302175'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Trace - Legacy wrapper fro L. + +=head1 DESCRIPTION + +All the functionality for this class has been moved to +L. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2/Util.pm ddclient-3.10.0/t/lib/Test2/Util.pm --- ddclient-3.9.1/t/lib/Test2/Util.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2/Util.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,448 @@ +package Test2::Util; +use strict; +use warnings; + +our $VERSION = '1.302175'; + +use POSIX(); +use Config qw/%Config/; +use Carp qw/croak/; + +BEGIN { + local ($@, $!, $SIG{__DIE__}); + *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; +} + +our @EXPORT_OK = qw{ + try + + pkg_to_file + + get_tid USE_THREADS + CAN_THREAD + CAN_REALLY_FORK + CAN_FORK + + CAN_SIGSYS + + IS_WIN32 + + ipc_separator + + gen_uid + + do_rename do_unlink + + try_sig_mask + + clone_io +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +BEGIN { + *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; +} + +sub _can_thread { + return 0 unless $] >= 5.008001; + return 0 unless $Config{'useithreads'}; + + # Threads are broken on perl 5.10.0 built with gcc 4.8+ + if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { + my @parts = split /\./, $Config{'gccversion'}; + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + + # Change to a version check if this ever changes + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + +sub _can_fork { + return 1 if $Config{d_fork}; + return 0 unless IS_WIN32 || $^O eq 'NetWare'; + return 0 unless $Config{useithreads}; + return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; + + return _can_thread(); +} + +BEGIN { + no warnings 'once'; + *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; +} +my $can_fork; +sub CAN_FORK () { + return $can_fork + if defined $can_fork; + $can_fork = !!_can_fork(); + no warnings 'redefine'; + *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; + $can_fork; +} +my $can_really_fork; +sub CAN_REALLY_FORK () { + return $can_really_fork + if defined $can_really_fork; + $can_really_fork = !!$Config{d_fork}; + no warnings 'redefine'; + *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; + $can_really_fork; +} + +sub _manual_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + my $die = delete $SIG{__DIE__}; + + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; + + return (!defined($err), $err); +} + +sub _local_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + no warnings; + local $SIG{__DIE__}; + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + return (!defined($err), $err); +} + +# Older versions of perl have a nasty bug on win32 when localizing a variable +# before forking or starting a new thread. So for those systems we use the +# non-local form. When possible though we use the faster 'local' form. +BEGIN { + if (IS_WIN32 && $] < 5.020002) { + *try = \&_manual_try; + } + else { + *try = \&_local_try; + } +} + +BEGIN { + if (CAN_THREAD) { + if ($INC{'threads.pm'}) { + # Threads are already loaded, so we do not need to check if they + # are loaded each time + *USE_THREADS = sub() { 1 }; + *get_tid = sub() { threads->tid() }; + } + else { + # :-( Need to check each time to see if they have been loaded. + *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; + *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; + } + } + else { + # No threads, not now, not ever! + *USE_THREADS = sub() { 0 }; + *get_tid = sub() { 0 }; + } +} + +sub pkg_to_file { + my $pkg = shift; + my $file = $pkg; + $file =~ s{(::|')}{/}g; + $file .= '.pm'; + return $file; +} + +sub ipc_separator() { "~" } + +my $UID = 1; +sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) } + +sub _check_for_sig_sys { + my $sig_list = shift; + return $sig_list =~ m/\bSYS\b/; +} + +BEGIN { + if (_check_for_sig_sys($Config{sig_name})) { + *CAN_SIGSYS = sub() { 1 }; + } + else { + *CAN_SIGSYS = sub() { 0 }; + } +} + +my %PERLIO_SKIP = ( + unix => 1, + via => 1, +); + +sub clone_io { + my ($fh) = @_; + my $fileno = eval { fileno($fh) }; + + return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; + + open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; + + my %seen; + my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); + binmode($out, join(":", "", "raw", @layers)); + + my $old = select $fh; + my $af = $|; + select $out; + $| = $af; + select $old; + + return $out; +} + +BEGIN { + if (IS_WIN32) { + my $max_tries = 5; + + *do_rename = sub { + my ($from, $to) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if rename($from, $to); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, $err); + }; + *do_unlink = sub { + my ($file) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if unlink($file); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, "$!"); + }; + } + else { + *do_rename = sub { + my ($from, $to) = @_; + return (1) if rename($from, $to); + return (0, "$!"); + }; + *do_unlink = sub { + my ($file) = @_; + return (1) if unlink($file); + return (0, "$!"); + }; + } +} + +sub try_sig_mask(&) { + my $code = shift; + + my ($old, $blocked); + unless(IS_WIN32) { + my $to_block = POSIX::SigSet->new( + POSIX::SIGINT(), + POSIX::SIGALRM(), + POSIX::SIGHUP(), + POSIX::SIGTERM(), + POSIX::SIGUSR1(), + POSIX::SIGUSR2(), + ); + $old = POSIX::SigSet->new; + $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); + # Silently go on if we failed to log signals, not much we can do. + } + + my ($ok, $err) = &try($code); + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + return ($ok, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util - Tools used by Test2 and friends. + +=head1 DESCRIPTION + +Collection of tools used by L and friends. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and the error message. This code +protects $@ and $!, they will be restored by the end of the run. This code also +temporarily blocks $SIG{DIE} handlers. + +=item protect { ... } + +Similar to try, except that it does not catch exceptions. The idea here is to +protect $@ and $! from changes. $@ and $! will be restored to whatever they +were before the run so long as it is successful. If the run fails $! will still +be restored, but $@ will contain the exception being thrown. + +=item CAN_FORK + +True if this system is capable of true or pseudo-fork. + +=item CAN_REALLY_FORK + +True if the system can really fork. This will be false for systems where fork +is emulated. + +=item CAN_THREAD + +True if this system is capable of using threads. + +=item USE_THREADS + +Returns true if threads are enabled, false if they are not. + +=item get_tid + +This will return the id of the current thread when threads are enabled, +otherwise it returns 0. + +=item my $file = pkg_to_file($package) + +Convert a package name to a filename. + +=item $string = ipc_separator() + +Get the IPC separator. Currently this is always the string C<'~'>. + +=item $string = gen_uid() + +Generate a unique id (NOT A UUID). This will typically be the process id, the +thread id, the time, and an incrementing integer all joined with the +C. + +These ID's are unique enough for most purposes. For identical ids to be +generated you must have 2 processes with the same PID generate IDs at the same +time with the same current state of the incrementing integer. This is a +perfectly reasonable thing to expect to happen across multiple machines, but is +quite unlikely to happen on one machine. + +This can fail to be unique if a process generates an id, calls exec, and does +it again after the exec and it all happens in less than a second. It can also +happen if the systems process id's cycle in less than a second allowing 2 +different programs that use this generator to run with the same PID in less +than a second. Both these cases are sufficiently unlikely. If you need +universally unique ids, or ids that are unique in these conditions, look at +L. + +=item ($ok, $err) = do_rename($old_name, $new_name) + +Rename a file, this wraps C in a way that makes it more reliable +cross-platform when trying to rename files you recently altered. + +=item ($ok, $err) = do_unlink($filename) + +Unlink a file, this wraps C in a way that makes it more reliable +cross-platform when trying to unlink files you recently altered. + +=item ($ok, $err) = try_sig_mask { ... } + +Complete an action with several signals masked, they will be unmasked at the +end allowing any signals that were intercepted to get handled. + +This is primarily used when you need to make several actions atomic (against +some signals anyway). + +Signals that are intercepted: + +=over 4 + +=item SIGINT + +=item SIGALRM + +=item SIGHUP + +=item SIGTERM + +=item SIGUSR1 + +=item SIGUSR2 + +=back + +=back + +=head1 NOTES && CAVEATS + +=over 4 + +=item 5.10.0 + +Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a +segfault whenever a new thread is launched. Test2 will attempt to detect +this, and note that the system is not capable of forking when it is detected. + +=item Devel::Cover + +Devel::Cover does not support threads. CAN_THREAD will return false if +Devel::Cover is loaded before the check is first run. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/lib/Test2.pm ddclient-3.10.0/t/lib/Test2.pm --- ddclient-3.9.1/t/lib/Test2.pm 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/lib/Test2.pm 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,213 @@ +package Test2; +use strict; +use warnings; + +our $VERSION = '1.302175'; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2 - Framework for writing test tools that all work together. + +=head1 DESCRIPTION + +Test2 is a new testing framework produced by forking L, +completely refactoring it, adding many new features and capabilities. + +=head2 WHAT IS NEW? + +=over 4 + +=item Easier to test new testing tools. + +From the beginning Test2 was built with introspection capabilities. With +Test::Builder it was difficult at best to capture test tool output for +verification. Test2 Makes it easy with C. + +=item Better diagnostics capabilities. + +Test2 uses an L object to track filename, line number, and +tool details. This object greatly simplifies tracking for where errors should +be reported. + +=item Event driven. + +Test2 based tools produce events which get passed through a processing system +before being output by a formatter. This event system allows for rich plugin +and extension support. + +=item More complete API. + +Test::Builder only provided a handful of methods for generating lines of TAP. +Test2 took inventory of everything people were doing with Test::Builder that +required hacking it up. Test2 made public API functions for nearly all the +desired functionality people didn't previously have. + +=item Support for output other than TAP. + +Test::Builder assumed everything would end up as TAP. Test2 makes no such +assumption. Test2 provides ways for you to specify alternative and custom +formatters. + +=item Subtest implementation is more sane. + +The Test::Builder implementation of subtests was certifiably insane. Test2 uses +a stacked event hub system that greatly improves how subtests are implemented. + +=item Support for threading/forking. + +Test2 support for forking and threading can be turned on using L. +Once turned on threading and forking operate sanely and work as one would +expect. + +=back + +=head1 GETTING STARTED + +If you are interested in writing tests using new tools then you should look at +L. L is a separate cpan distribution that contains +many tools implemented on Test2. + +If you are interested in writing new tools you should take a look at +L first. + +=head1 NAMESPACE LAYOUT + +This describes the namespace layout for the Test2 ecosystem. Not all the +namespaces listed here are part of the Test2 distribution, some are implemented +in L. + +=head2 Test2::Tools:: + +This namespace is for sets of tools. Modules in this namespace should export +tools like C and C. Most things written for Test2 should go here. +Modules in this namespace B export subs from other tools. See the +L namespace if you want to do that. + +=head2 Test2::Plugin:: + +This namespace is for plugins. Plugins are modules that change or enhance the +behavior of Test2. An example of a plugin is a module that sets the encoding to +utf8 globally. Another example is a module that causes a bail-out event after +the first test failure. + +=head2 Test2::Bundle:: + +This namespace is for bundles of tools and plugins. Loading one of these may +load multiple tools and plugins. Modules in this namespace should not implement +tools directly. In general modules in this namespace should load tools and +plugins, then re-export things into the consumers namespace. + +=head2 Test2::Require:: + +This namespace is for modules that cause a test to be skipped when conditions +do not allow it to run. Examples would be modules that skip the test on older +perls, or when non-essential modules have not been installed. + +=head2 Test2::Formatter:: + +Formatters live under this namespace. L is the only +formatter currently. It is acceptable for third party distributions to create +new formatters under this namespace. + +=head2 Test2::Event:: + +Events live under this namespace. It is considered acceptable for third party +distributions to add new event types in this namespace. + +=head2 Test2::Hub:: + +Hub subclasses (and some hub utility objects) live under this namespace. It is +perfectly reasonable for third party distributions to add new hub subclasses in +this namespace. + +=head2 Test2::IPC:: + +The IPC subsystem lives in this namespace. There are not many good reasons to +add anything to this namespace, with exception of IPC drivers. + +=head3 Test2::IPC::Driver:: + +IPC drivers live in this namespace. It is fine to create new IPC drivers and to +put them in this namespace. + +=head2 Test2::Util:: + +This namespace is for general utilities used by testing tools. Please be +considerate when adding new modules to this namespace. + +=head2 Test2::API:: + +This is for Test2 API and related packages. + +=head2 Test2:: + +The Test2:: namespace is intended for extensions and frameworks. Tools, +Plugins, etc should not go directly into this namespace. However extensions +that are used to build tools and plugins may go here. + +In short: If the module exports anything that should be run directly by a test +script it should probably NOT go directly into C. + +=head1 SEE ALSO + +L - Primary API functions. + +L - Detailed documentation of the context object. + +L - The IPC system used for threading/fork support. + +L - Formatters such as TAP live here. + +L - Events live in this namespace. + +L - All events eventually funnel through a hub. Custom hubs are how +C and C are implemented. + +=head1 CONTACTING US + +Many Test2 developers and users lurk on L and +L. We also have a slack team that can be joined +by anyone with an C<@cpan.org> email address L +If you do not have an C<@cpan.org> email you can ask for a slack invite by +emailing Chad Granum Eexodist@cpan.orgE. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2019 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff -Nru ddclient-3.9.1/t/parse_assignments.pl ddclient-3.10.0/t/parse_assignments.pl --- ddclient-3.9.1/t/parse_assignments.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/parse_assignments.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,57 @@ +use Test::More; +use Data::Dumper; + +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +$Data::Dumper::Sortkeys = 1; + +sub tc { + return { + name => shift, + input => shift, + want_vars => shift, + want_rest => shift, + }; +} + +my @test_cases = ( + tc('no assignments', "", {}, ""), + tc('one assignment', "a=1", { a => '1' }, ""), + tc('empty value', "a=", { a => '' }, ""), + tc('sep: comma', "a=1,b=2", { a => '1', b => '2' }, ""), + tc('sep: space', "a=1 b=2", { a => '1', b => '2' }, ""), + tc('sep: comma space', "a=1, b=2", { a => '1', b => '2' }, ""), + tc('sep: space comma', "a=1 ,b=2", { a => '1', b => '2' }, ""), + tc('sep: space comma space', "a=1 , b=2", { a => '1', b => '2' }, ""), + tc('leading space', " a=1", { a => '1' }, ""), + tc('trailing space', "a=1 ", { a => '1' }, ""), + tc('leading comma', ",a=1", { a => '1' }, ""), + tc('trailing comma', "a=1,", { a => '1' }, ""), + tc('empty assignment', "a=1,,b=2", { a => '1', b => '2' }, ""), + tc('rest', "a", {}, "a"), + tc('rest leading space', " x", {}, "x"), + tc('rest trailing space', "x ", {}, "x "), + tc('rest leading comma', ",x", {}, "x"), + tc('rest trailing comma', "x,", {}, "x,"), + tc('assign space rest', "a=1 x", { a => '1' }, "x"), + tc('assign comma rest', "a=1,x", { a => '1' }, "x"), + tc('assign comma space rest', "a=1, x", { a => '1' }, "x"), + tc('assign space comma rest', "a=1 ,x", { a => '1' }, "x"), + tc('single quoting', "a='\", '", { a => '", ' }, ""), + tc('double quoting', "a=\"', \"", { a => "', " }, ""), + tc('mixed quoting', "a=1\"2\"'3'4", { a => "1234" }, ""), + tc('unquoted escaped backslash', "a=\\\\", { a => "\\" }, ""), + tc('squoted escaped squote', "a='\\''", { a => "'" }, ""), + tc('dquoted escaped dquote', "a=\"\\\"\"", { a => '"' }, ""), +); + +for my $tc (@test_cases) { + my ($got_rest, %got_vars) = ddclient::parse_assignments($tc->{input}); + subtest $tc->{name} => sub { + is(Dumper(\%got_vars), Dumper($tc->{want_vars}), "vars"); + is($got_rest, $tc->{want_rest}, "rest"); + } +} + +done_testing(); diff -Nru ddclient-3.9.1/t/version.pl.in ddclient-3.10.0/t/version.pl.in --- ddclient-3.9.1/t/version.pl.in 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/version.pl.in 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,9 @@ +use Test::More; +use version; + +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +is(ddclient->VERSION(), version->parse('v@PACKAGE_VERSION@'), "version matches Autoconf config"); + +done_testing(); diff -Nru ddclient-3.9.1/t/write_cache.pl ddclient-3.10.0/t/write_cache.pl --- ddclient-3.9.1/t/write_cache.pl 1970-01-01 00:00:00.000000000 +0000 +++ ddclient-3.10.0/t/write_cache.pl 2022-10-20 18:06:35.000000000 +0000 @@ -0,0 +1,49 @@ +use Test::More; +use File::Spec::Functions; +use File::Temp; +eval { require Test::MockModule; } or plan(skip_all => $@); +SKIP: { eval { require Test::Warnings; } or skip($@, 1); } +eval { require 'ddclient'; } or BAIL_OUT($@); + +my $warning; + +my $module = Test::MockModule->new('ddclient'); +# Note: 'mock' is used instead of 'redefine' because 'redefine' is not available in the versions of +# Test::MockModule distributed with old Debian and Ubuntu releases. +$module->mock('warning', sub { + BAIL_OUT("warning already logged") if defined($warning); + $warning = sprintf(shift, @_); +}); +my $tmpdir = File::Temp->newdir(); +my $dir = $tmpdir->dirname(); +diag("temporary directory: $dir"); + +sub tc { + return { + name => shift, + f => shift, + warning_regex => shift, + }; +} + +my @test_cases = ( + tc("create cache file", catfile($dir, 'a', 'b', 'cachefile'), undef), + tc("overwrite cache file", catfile($dir, 'a', 'b', 'cachefile'), undef), + tc("bad directory", catfile($dir, 'a', 'b', 'cachefile', 'bad'), qr/Failed to create/i), + tc("bad file", catfile($dir, 'a', 'b'), qr/Failed to create/i), +); + +for my $tc (@test_cases) { + $warning = undef; + ddclient::write_cache($tc->{f}); + subtest $tc->{name} => sub { + if (defined($tc->{warning_regex})) { + like($warning, $tc->{warning_regex}, "expected warning message"); + } else { + ok(!defined($warning), "no warning"); + ok(-f $tc->{f}, "cache file exists"); + } + }; +} + +done_testing(); diff -Nru ddclient-3.9.1/TODO ddclient-3.10.0/TODO --- ddclient-3.9.1/TODO 2020-01-08 09:56:03.000000000 +0000 +++ ddclient-3.10.0/TODO 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -* ssl: - - check if the library can be used - - ssl on routers - - ssl on other providers - -* notice about irc: there's almost always someone there but we're sometimes idle -or at work... -* adding router: halted, only in patches section. -* add doc postscript -* FAQ: bad hostname (checkip) -* note about init-scripts. -* request from dyndns: http://tinyurl.com/2l3twf - -* check bugs