pax_global_header00006660000000000000000000000064145276400750014524gustar00rootroot0000000000000052 comment=4a1b06630b90b3e6ff1d837b849bdbc68a2f53f9 ddclient-3.11.2/000077500000000000000000000000001452764007500133765ustar00rootroot00000000000000ddclient-3.11.2/.envrc000066400000000000000000000000761452764007500145170ustar00rootroot00000000000000if has lorri; then eval "$(lorri direnv)" else use nix fi ddclient-3.11.2/.github/000077500000000000000000000000001452764007500147365ustar00rootroot00000000000000ddclient-3.11.2/.github/workflows/000077500000000000000000000000001452764007500167735ustar00rootroot00000000000000ddclient-3.11.2/.github/workflows/ci.yml000066400000000000000000000071021452764007500201110ustar00rootroot00000000000000name: CI on: push: pull_request: jobs: test-debian-like: strategy: matrix: image: - ubuntu:latest - ubuntu:20.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 \ curl \ libhttp-daemon-perl \ libhttp-daemon-ssl-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-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 \ curl \ 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 ddclient-3.11.2/.github/workflows/scripts/000077500000000000000000000000001452764007500204625ustar00rootroot00000000000000ddclient-3.11.2/.github/workflows/scripts/dist-tarball-check000077500000000000000000000043601452764007500240500ustar00rootroot00000000000000#!/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 \ docs/ProviderGuidelines.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" ddclient-3.11.2/.gitignore000066400000000000000000000004341452764007500153670ustar00rootroot00000000000000patches release .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 ddclient-3.11.2/CONTRIBUTING.md000066400000000000000000000251361452764007500156360ustar00rootroot00000000000000# 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 ``` ddclient-3.11.2/COPYING000066400000000000000000000431061452764007500144350ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy 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 of the License, 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, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ddclient-3.11.2/COPYRIGHT000066400000000000000000000015451452764007500146760ustar00rootroot00000000000000ddclient - update client for www.dyndns.org accounts Copyright (C) 1999 Paul Burry (paul@burry.ca) Copyright (C) 2000 Paul Burry (paul@burry.ca) Copyright (C) 2001 Paul Burry (paul@burry.ca) 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 of the License, 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, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ddclient-3.11.2/ChangeLog.md000066400000000000000000001156341452764007500155610ustar00rootroot00000000000000# ChangeLog This document describes notable changes. For details, see the [source code repository history](https://github.com/ddclient/ddclient/commits/master). ## 2023-11-23 v3.11.2 ### Bug fixes * Fixed simultaneous IPv4 and IPv6 updates for provider duckdns * Fixed caching issues for new providers when using the old 'use' config parameter ## 2023-10-25 v3.11.1 ### Bug fixes * Fixed simultaneous IPv4 and IPv6 updates for provider porkbun * Removed @PACKAGE_VERSION@ placeholder in ddclient.in for now to allow downstream to adopt the proper build process first. See [here](https://github.com/ddclient/ddclient/issues/579) for the discussion. ## 2023-10-21 v3.11.0 This version is the same as v3.11.0_1 (except for the updated version number in the code). Refer to [v3.11 release plan discussions](https://github.com/ddclient/ddclient/issues/552) for the reasons. ## 2023-10-15 v3.11.0_1 ### Breaking changes * ddclient now requires curl. The Perl modules IO::Socket::IP and IO::Socket::SSL are no longer used. * ddclient no longer ships any example files for init systems that use `/etc/init.d`. This was done because those files where effectively unmaintained, untested by the developers and only updated by downstream distros. If you where relying on those files, please copy them into your packaging. * The defunct `dnsexit` protocol is removed (replaced by `dnsexit2`). ### New features * Introduced `usev4` and `usev6` for separate IPv4/IPv6 configuration. These will replace the legacy `use` eventually. * Added support for moving secrets out of the configuration through environment variables * Extended postscript mechanism * sample-get-ip-from-fritzbox: Added environment variable to override hostname * Warn about hosts where no IP could be determined - and skip the (bogus) update. ### Provider updates: * Added regfish * Added domeneshop.no * Added Mythic Beasts * Added Porkbun * Added Enom * Added DigitalOcean * Added Infomaniak * Added DNSExit API v2 * Removed old DNSExit API * Extended EasyDNS to support IPv6 * Extended duckdns to support IPv6 ### Bug fixes * Fixed various issues with caching * Fixed issues with Hetzner zones * The OVH provider now ignores extra data returned * Merge multiple configs for the same hostname instead of use the last ## 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 ddclient-3.11.2/Makefile.am000066400000000000000000000102551452764007500154350ustar00rootroot00000000000000ACLOCAL_AMFLAGS = -I m4 EXTRA_DIST = \ CONTRIBUTING.md \ COPYING \ COPYRIGHT \ ChangeLog.md \ README.cisco \ README.md \ 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_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/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 ddclient-3.11.2/README.cisco000066400000000000000000000021141452764007500153530ustar00rootroot00000000000000Method 1 ------------------------------------------------------ The following config will allow the Linux machine (10.1.1.2) to read the IP address from the DHCP interface on the Cisco router (eth0) as user ddclient. Since ddclient is configured with a priv level of 1 it cannot do anything except look at the routers stats, ip addresses, etc. This should be pretty harmless even if ddclient's password were to be discovered. This has been tested with Cisco IOS 12.1(5)T5 running on a Cisco 2621 router. Cisco Router Config (Assuming eth0 is DHCP interface) ----------------------------------------------------- user ddclient password password user ddclient priv 1 ip http auth local ip http access-class 99 ip http port 1021 ip http server access-list 99 permit host 10.1.1.2 DDClient Config --------------------------------------------------- use=cisco, fw=10.1.1.1, if=eth0, fw-login=ddclient, fw-password=password Method 2 ------------------------------------------------------ use=fw fw=192.168.1.1/exec/show/interfaces/CR fw-skip=FastEthernet0/0 fw-login=ddclient fw-password=xxxxxxxx ddclient-3.11.2/README.md000066400000000000000000000167201452764007500146630ustar00rootroot00000000000000# DDCLIENT `ddclient` is a Perl client used to update dynamic DNS entries for accounts on many dynamic DNS services. It uses `curl` for internet access. This is a friendly fork/continuation of https://github.com/ddclient/ddclient ## Alternatives You might also want to consider using one of the following, if they support your dynamic DNS provider(s): or . ## Supported services Dynamic DNS services currently supported include: * [1984.is](https://www.1984.is/product/freedns) * [ChangeIP](https://www.changeip.com) * [CloudFlare](https://www.cloudflare.com) * [ClouDNS](https://www.cloudns.net) * [DigitalOcean](https://www.digitalocean.com/) * [dinahosting](https://dinahosting.com) * [DonDominio](https://www.dondominio.com) * [DNS Made Easy](https://dnsmadeeasy.com) * [DNSExit](https://dnsexit.com/dns/dns-api) * [Domeneshop](https://api.domeneshop.no/docs/#tag/ddns/paths/~1dyndns~1update/get) * [DslReports](https://www.dslreports.com) * [Duck DNS](https://duckdns.org) * [DynDNS.com](https://account.dyn.com) * [EasyDNS](https://www.easydns.com ) * [Enom](https://www.enom.com) * [Freedns](https://freedns.afraid.org) * [Freemyip](https://freemyip.com) * [Gandi](https://gandi.net) * [GoDaddy](https://www.godaddy.com) * [Google](https://domains.google) * [Infomaniak](https://faq.infomaniak.com/2376) * [Loopia](https://www.loopia.se) * [Mythic Beasts](https://www.mythic-beasts.com/support/api/dnsv2/dynamic-dns) * [NameCheap](https://www.namecheap.com) * [NearlyFreeSpeech.net](https://www.nearlyfreespeech.net/services/dns) * [Njalla](https://njal.la/docs/ddns) * [Noip](https://www.noip.com) * nsupdate - see nsupdate(1) and ddns-confgen(8) * [OVH](https://www.ovhcloud.com) * [Porkbun](https://porkbun.com) * [regfish.de](https://www.regfish.de/domains/dyndns) * [Sitelutions](https://www.sitelutions.com) * [woima.fi](https://woima.fi) * [Yandex](https://dns.yandex.com) * [Zoneedit](https://www.zoneedit.com) `ddclient` supports finding your IP address from many cable and DSL broadband routers. Comments, suggestions and requests: please file an issue at https://github.com/ddclient/ddclient/issues/new The code was originally written by Paul Burry and is now hosted and maintained through github.com. Please check out https://ddclient.net ## REQUIREMENTS * An account from a supported dynamic DNS service provider * Perl v5.10.1 or later * `JSON::PP` perl library for JSON 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.XX.X.tar.gz cd ddclient-3.XX.X ``` (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 ``` 3. Edit `/etc/ddclient/ddclient.conf`. #### systemd cp sample-etc_systemd.service /etc/systemd/system/ddclient.service enable automatic startup when booting systemctl enable ddclient.service start the first time by hand systemctl start ddclient.service ## 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. 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. 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`` 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 OR Send me the output from: ``$ 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`` 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` If you are using a ppp connection, you can easily update your DynDNS entry with each connection, with: ## configure pppd to update DynDNS with each connection cp sample-etc_ppp_ip-up.local /etc/ppp/ip-up.local Alternatively, you may just configure ddclient to operate as a daemon and monitor your ppp interface. ## 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 not become stale. ## configure cron to force an update twice a month cp sample-etc_cron.d_ddclient /etc/cron.d/ddclient vi /etc/cron.d/ddclient ## USING DDCLIENT WITH `dhcpcd` 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`` ie.: ``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: ```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. Alternatively, you may just configure ddclient to operate as a daemon and monitor your ethernet interface. ## 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`` ie.: ``cp sample-etc_dhclient-exit-hooks /etc/dhclient-exit-hooks`` 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. ddclient-3.11.2/autogen000077500000000000000000000016331452764007500147710ustar00rootroot00000000000000#!/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 ddclient-3.11.2/build-aux/000077500000000000000000000000001452764007500152705ustar00rootroot00000000000000ddclient-3.11.2/build-aux/tap-driver.sh000077500000000000000000000460131452764007500177100ustar00rootroot00000000000000#! /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: ddclient-3.11.2/configure.ac000066400000000000000000000055641452764007500156760ustar00rootroot00000000000000AC_PREREQ([2.63]) AC_INIT([ddclient], [3.11.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]) AS_IF([test -z "${CURL}"], [AC_MSG_ERROR([curl not found])]) 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 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 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 ddclient-3.11.2/ddclient.conf.in000066400000000000000000000237601452764007500164500ustar00rootroot00000000000000###################################################################### ## ## 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" (without 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 ## ## Porkbun (https://porkbun.com/) ## # protocol=porkbun # apikey=APIKey # secretapikey=SecretAPIKey # host.example.com,host2.sub.example.com # on-root-domain=yes example.com,sub.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 ## ## dnsexit2 (API method www.dnsexit.com) ## #protocol=dnsexit2 #password=MyAPIKey #subdomain-1.domain.com,subdomain-2.domain.com ## ## domeneshop (www.domeneshop.no) ## # protocol=domeneshop # login= # password= # subdomain-1.domain.com,subdomain-2.domain.com ## ## Njal.la (http://njal.la/) ## # protocol=njalla, # password=mypassword # quietreply=no|yes # my-domain.com ## ## regfish.de (www.regfish.de/) ## # protocol=regfishde, # password=mypassword # my-domain.com ## ## Enom (www.enom.com) ## # protocol=enom, # login=domain.name, # password=domain-password # my-domain.com ## ## DigitalOcean (www.digitalocean.com) ## #protocol=digitalocean, \ #zone=example.com, \ #password=api-token \ #example.com,sub.example.com ## ## Infomaniak (www.infomaniak.com) ## # protocol=infomaniak, # login=ddns_username, # password=ddns_password # example.com ddclient-3.11.2/ddclient.in000077500000000000000000011560531452764007500155320ustar00rootroot00000000000000#!/usr/bin/perl ###################################################################### # # DDCLIENT - a Perl client for updating DynDNS information # # Original Author: Paul Burry (paul+ddclient@burry.ca) # Current maintainers: # Reuben Thomas # Lenard Heß # # website: https://github.com/ddclient/ddclient # ###################################################################### 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 Sys::Hostname; use version 0.77; our $VERSION = version->declare('3.11.2'); my $version = $VERSION->stringify(); 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' => 'https://ipv4.nsupdate.info/myip'}, 'nsupdate.info-ipv6' => {'url' => 'https://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), '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), 'usev4' => setv(T_USEV4, 0, 0, 'disabled', undef), 'usev6' => setv(T_USEV6, 0, 0, 'disabled', 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,0, 0, '', undef), 'web-ssl-validate' => setv(T_BOOL, 0, 0, 1, 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,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), '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), 'cmd' => setv(T_PROG, 0, 0, '', undef), 'cmd-skip' => setv(T_STRING,0, 0, '', undef), 'cmdv4' => setv(T_PROG, 0, 0, '', undef), 'cmdv6' => setv(T_PROG, 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, 'dynamicdns.key-systems.net', undef), 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), }, 'dnsexit2-common-defaults' => { 'ssl' => setv(T_BOOL, 0, 0, 1, undef), 'server' => setv(T_FQDNP, 1, 0, 'api.dnsexit.com', undef), 'path' => setv(T_STRING, 0, 0, '/dns/', undef), 'ttl' => setv(T_NUMBER, 1, 0, 5, 0), 'zone' => setv(T_STRING, 0, 0, undef, undef) }, 'regfishde-common-defaults' => { 'server' => setv(T_FQDNP, 1, 0, 'dyndns.regfish.de', undef), 'login' => setv(T_LOGIN, 0, 0, 0, 'unused', undef), }, ); 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), }, }, 'digitalocean' => { 'updateable' => undef, 'update' => \&nic_digitalocean_update, 'examples' => \&nic_digitalocean_examples, 'variables' => { %{$variables{'service-common-defaults'}}, 'server' => setv(T_FQDNP, 1, 0, 'api.digitalocean.com', undef), 'zone' => setv(T_FQDN, 1, 0, '', undef), 'login' => setv(T_LOGIN, 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), }, }, 'domeneshop' => { 'updateable' => undef, 'update' => \&nic_domeneshop_update, 'examples' => \&nic_domeneshop_examples, 'variables' => { %{$variables{'service-common-defaults'}}, 'server' => setv(T_FQDNP, 1, 0, 'api.domeneshop.no', 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), }, }, 'mythicdyn' => { 'updateable' => undef, 'update' => \&nic_mythicdyn_update, 'examples' => \&nic_mythicdyn_examples, 'variables' => { %{$variables{'service-common-defaults'}}, 'min-interval' => setv(T_DELAY, 0, 0, interval('5m'), 0), 'server' => setv(T_FQDNP, 1, 0, 'api.mythic-beasts.com', 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), }, }, 'porkbun' => { 'updateable' => undef, 'update' => \&nic_porkbun_update, 'examples' => \&nic_porkbun_examples, 'variables' => { 'apikey' => setv(T_PASSWD, 1, 0, '', undef), 'secretapikey' => setv(T_PASSWD, 1, 0, '', undef), 'on-root-domain' => setv(T_BOOL, 0, 0, 0, undef), 'login' => setv(T_LOGIN, 0, 0, 'unused', undef), 'password' => setv(T_PASSWD, 0, 0, 'unused', undef), 'use' => setv(T_USE, 0, 0, 'disabled', undef), 'usev4' => setv(T_USEV4, 0, 0, 'disabled', undef), 'usev6' => setv(T_USEV6, 0, 0, 'disabled', 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('10m'), 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'}, ), }, 'dnsexit2' => { 'updateable' => undef, 'update' => \&nic_dnsexit2_update, 'examples' => \&nic_dnsexit2_examples, 'variables' => { %{$variables{'service-common-defaults'}}, %{$variables{'dnsexit2-common-defaults'}}, # nic_updateable() assumes that every service uses a username/login but that is # not true for the DNSExit API. Silence warnings by redefining the username variable # as non-required with value unused. 'login' => setv(T_STRING, 0, 0, 'unused', undef), }, }, 'regfishde' => { 'updateable' => undef, 'update' => \&nic_regfishde_update, 'examples' => \&nic_regfishde_examples, 'variables' => merge( $variables{'regfishde-common-defaults'}, $variables{'service-common-defaults'}, ), }, 'enom' => { 'updateable' => undef, 'update' => \&nic_enom_update, 'examples' => \&nic_enom_examples, 'variables' => { %{$variables{'service-common-defaults'}}, 'server' => setv(T_FQDNP, 1, 0, 'dynamic.name-services.com', undef), 'min-interval' => setv(T_DELAY, 0, 0, 0, interval('5m')), }, }, 'infomaniak' => { 'updateable' => undef, 'update' => \&nic_infomaniak_update, 'examples' => \&nic_infomaniak_examples, 'variables' => { %{$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"], ["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}) { my @postscript = split(/\s+/, $globals{postscript}); if (-x $postscript[0]) { 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 $use = 'disabled' if ($usev4 ne 'disabled') || ($usev6 ne 'disabled'); 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); if (!$ip && !$ipv4 && !$ipv6) { warning("Could not determine an IP for %s", $h); next; } 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); # Backwards compatibility: # The legacy 'use' parameter sets 'wantip' and the legacy providers process this and # set 'ip', 'status' accordingly. # The new 'usev*' parameters set 'wantipv*' and the new providers set 'ipv*' and 'status-ipv*'. # To allow gradual transition, we make sure both the old 'status' and 'ip' are being set # accordingly to what new providers returned in the new 'status-ipv*' and 'ipv*' fields respectively. foreach my $h (@hosts) { $config{$h}{'status'} //= $config{$h}{'status-ipv4'}; $config{$h}{'status'} //= $config{$h}{'status-ipv6'}; $config{$h}{'ip'} //= $config{$h}{'ipv4'}; $config{$h}{'ip'} //= $config{$h}{'ipv6'}; } 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*)(.*)/) { 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) { # Handle '_env' keyword suffix if ($k =~ /(.*)_env$/) { debug("Loading value for $1 from environment variable $locals{$k}."); if (exists($ENV{$locals{$k}})) { # Set the value to the value of the environment variable $locals{$1} = $ENV{$locals{$k}}; # Remove the '_env' suffix from the key $k = $1; } else { warning("Environment variable '$locals{$k}' not set for keyword '$k' (ignored)"); delete $locals{$k}; next; } } $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)) { if ($config{$h}) { ## host already defined, merging configs $config{$h} = { %{merge($config{$h}, \%locals)} }; } else { ## 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", "digitalocean", "gandi", "godaddy", "hetzner", "yandex", "nfsn", "njalla", "porkbun", "dnsexit2"))); 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_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/); } ###################################################################### ## 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 => "$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; } sub geturl { 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 { 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 $use = 'disabled' if ($usev4 ne 'disabled') || ($usev6 ne 'disabled'); # 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, $ipv4); } 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: authentication failed (%s)", $host, $line); } elsif ($result eq '403') { failed("updating %s: not authorized (%s)", $host, $line); } } else { failed("updating %s: unexpected line (%s)", $host, $line); } return $ok; } ###################################################################### ## DDNS providers # A DDNS provider consists of an example function, the update # function, and an optional updateable function. # # The example function simply returns a string for the help message, # explaining how to configure the provider # # The update function performs the actual record update. # It receives an array of hosts as its argument. # # The updateable function allows a provider implementation to force # an update even if ddclient has itself determined no update is # necessary. The function shall return 1 if an update should be # performed, else 0. ###################################################################### ###################################################################### ## 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 $ipv4 = $config{$h}{'wantipv4'}; my $ipv6 = $config{$h}{'wantipv6'}; delete $config{$_}{'wantipv4'} foreach @hosts; delete $config{$_}{'wantipv6'} foreach @hosts; info("setting IPv4 address to %s for %s", $ipv4, $hosts) if $ipv4; info("setting IPv6 address to %s for %s", $ipv6, $hosts) if $ipv6; 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 .= $ipv4 if $ipv4; if ($ipv6) { $url .= "," if $ipv4; $url .= $ipv6; } ## 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'; 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, $returnedips) = split / /, lc $line; foreach my $h (@hosts) { $config{$h}{'status'} = $status; $config{$h}{'status-ipv4'} = $status if $ipv4; $config{$h}{'status-ipv6'} = $status if $ipv6; } if ($status eq 'good') { foreach my $h (@hosts) { $config{$h}{'ipv4'} = $ipv4 if $ipv4; $config{$h}{'ipv6'} = $ipv6 if $ipv6; $config{$h}{'mtime'} = $now; } success("updating %s: %s: IPv4 address set to %s", $hosts, $status, $ipv4) if $ipv4; success("updating %s: %s: IPv6 address set to %s", $hosts, $status, $ipv6) if $ipv6; } elsif (exists $errors{$status}) { if ($status eq 'nochg') { warning("updating %s: %s: %s", $hosts, $status, $errors{$status}); foreach my $h (@hosts) { $config{$h}{'ipv4'} = $ipv4 if $ipv4; $config{$h}{'ipv6'} = $ipv6 if $ipv6; $config{$h}{'mtime'} = $now; $config{$h}{'status'} = 'good'; $config{$h}{'status-ipv4'} = 'good' if $ipv4; $config{$h}{'status-ipv6'} = 'good' if $ipv6; } } else { failed("updating %s: %s: %s", $hosts, $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; foreach my $h (@hosts) { $config{$h}{'wtime'} = $now + $sec; } warning("updating %s: %s: wait %s %s before further updates", $hosts, $status, $wait, $units); } else { failed("updating %s: unexpected status (%s)", $hosts, $line); } } } failed("updating %s: Could not connect to %s.", $hosts, $config{$h}{'server'}) if $state ne 'results2'; } } ###################################################################### ## nic_dnsexit2_examples ###################################################################### sub nic_dnsexit2_examples { return <<"EoEXAMPLE"; o 'dnsexit2' The 'dnsexit2' protocol is the updated protocol for the (free) dynamic hostname services of 'DNSExit' (www.dnsexit.com). Their API is accepting JSON payload. Configuration variables applicable to the 'dnsexit2' protocol are: protocol=dnsexit2 ## password=YourAPIKey ## API Key of your account. server=api.dnsexit.com ## defaults to api.dnsexit.com. path=/dns/ ## defaults to /dns/. ttl=5 ## defaults to 5 minutes. zone='' ## defaults to empty, which assumes the zone is equal to the fully.qualified.host (is root of your DNSExit domain). fully.qualified.host ## the host registered with the service. Example ${program}.conf file entries: ## single host update protocol=dnsexit2 password=YourAPIKey yourown.publicvm.com ## two hosts (which must be) on the same zone protocol=dnsexit2 password=YourAPIKey zone=yourown.publicvm.com host1.yourown.publicvm.com,host2.yourown.publicvm.com EoEXAMPLE } ###################################################################### ## nic_dnsexit2_update ## ## by @jortkoopmans ## based on https://dnsexit.com/dns/dns-api/ ## ###################################################################### sub nic_dnsexit2_update { debug("\nnic_dnsexit2_update -------------------"); ## Update each configured host (hosts cannot be grouped on this API) foreach my $h (@_) { # All the known status my %status = ( '0' => [ 'good', 'Success! Actions got executed successfully.' ], '1' => [ 'warning', 'Some execution problems. May not indicate actions failures. Some action may got executed fine and some may have problems.' ], '2' => [ 'badauth', 'API Key Authentication Error. The API Key is missing or wrong.' ], '3' => [ 'error', 'Missing Required Definitions. Your JSON file may missing some required definitions.' ], '4' => [ 'error', 'JSON Data Syntax Error. Your JSON file has syntax error.' ], '5' => [ 'error', 'JSON Defined Record Type not Supported. Your JSON may try to update some record type not supported by our system.' ], '6' => [ 'error', 'System Error. Our system problem. May not be your problem. Contact our support if you got such error.' ], '7' => [ 'error', 'Error getting post data. Our server has problem to receive your JSON posting.' ], ); my $ipv4 = delete $config{$h}{'wantipv4'}; my $ipv6 = delete $config{$h}{'wantipv6'}; # Updates for ipv4 and ipv6 need to be combined in a single API call, create Hash of Arrays for tracking my %total_payload; foreach my $ip ($ipv4, $ipv6){ next if (!$ip); my $ipv = ($ip eq ($ipv6 // '')) ? '6' : '4'; my $type = ($ip eq ($ipv6 // '')) ? 'AAAA' : 'A'; info("Going to update IPv$ipv address to %s for %s.", $ip, $h); $config{$h}{'status-ipv$ipv'} = 'failed'; # One key per ipv (4 or 6) my %payload = (name => $h, type => $type, content => $ip, ttl => $config{$h}{'ttl'}); @total_payload{$ipv} = \%payload; }; # Set the URL of the API endpoint my $url = "https://$config{$h}{'server'}$config{$h}{'path'}"; # Set additional headers my $header = "Content-Type: application/json\nAccept: application/json"; # Set the zone if empty if ( not defined $config{$h}{'zone'}){ debug("Zone not defined, setting to default hostname: %s", $h); $config{$h}{'zone'} = $h } else { debug("Zone is: %s", $config{$h}{'zone'}); } # Build total JSON payload my @payload_values = values %total_payload; my $data = encode_json({ apikey => $config{$h}{'password'}, domain => $config{$h}{'zone'}, update => \@payload_values }); # Make the call my $reply = geturl( proxy => opt('proxy'), url => $url, headers => $header, method => 'POST', data => $data ); # No reply, declare as failed unless ($reply && header_ok($h, $reply)){ failed("updating %s: Could not connect to %s%s.", $h, $config{$h}{'server'}, $config{$h}{'path'}); last; }; # Reply found debug("%s", $reply); # Extract the HTTP response code (my $http_status) = ($reply =~ m%^s*HTTP/.*\s+(\d+)%i); debug("HTTP response code: %s", $http_status); # If not 200, bail if ( $http_status ne '200' ){ failed("Failed to update Host\n%s", $h); failed("HTTP response code\n%s", $http_status); failed("Full reply\n%s", $reply) unless opt('verbose'); next; } # Strip HTTP response headers (my $strip_status) = ($reply =~ s/^[\s\S]*?(?=\{"code":)//); debug("strip_status"); debug("%s", $strip_status); if ($strip_status) { debug("HTTP headers are stripped."); } else { warning("Unexpected: no HTTP headers stripped!"); } # Decode the remaining reply, it should be JSON. my $response = decode_json($reply); # It should at least have a 'code' and 'message'. if (defined($response->{'code'}) and defined($response->{'message'})) { if (exists $status{$response->{'code'}}) { # Add the server response data to the applicable array push( @{ $status {$response->{'code'} } }, $response->{'message'}); if (defined($response->{'details'})) { push ( @{ $status {$response->{'code'} } }, $response->{'details'}[0]); } else { # Keep it symmetrical for simplicity push ( @{ $status {$response->{'code'} } }, "no details received"); } # Set data from array my ($status, $message, $srv_message, $srv_details) = @{ $status {$response->{'code'} } }; info("Status: %s -- Message: %s", $status, $message); info("Server Message: %s -- Server Details: %s", $srv_message, $srv_details); $config{$h}{'status'} = $status; # Handle statuses if ($status eq 'good') { $config{$h}{'mtime'} = $now; my $tracked_ipv; foreach $tracked_ipv ( keys %total_payload ){ $config{$h}{"ipv$tracked_ipv"} = $total_payload{$tracked_ipv}{content}; $config{$h}{"status-ipv$tracked_ipv"} = 'good'; success("%s", $message); success("Updated %s successfully to IPv$tracked_ipv address %s at time %s", $h, $total_payload{$tracked_ipv}{content}, prettytime($config{$h}{'mtime'})); } } elsif ($status eq 'warning') { warning("%s", $message); warning("Server response: %s", $srv_message); } elsif ($status =~ m'^(badauth|error)$') { failed("%s", $message); failed("Server response: %s", $srv_message); } else { failed("This should not be possible"); } } else { failed("Status code %s is unknown!", $response->{'code'}); } } else { failed("Did not receive expected \"code\" and \"message\" keys in server response."); failed("Response:"); failed("%s", $response); } } } ###################################################################### ## 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 https://www.no-ip.com', 'numhost' => 'System error: Too many or too few hosts found. open a trouble ticket at https://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=noip&hostname=$hosts&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_domeneshop_examples ###################################################################### sub nic_domeneshop_examples { return <<"EoEXAMPLE"; o 'domeneshop' API is documented here: https://api.domeneshop.no/docs/ To generate credentials, visit https://www.domeneshop.no/admin?view=api after logging in to the control panel at https://www.domeneshop.no/admin?view=api Configuration variables applicable to the 'domeneshop' api are: protocol=domeneshop ## login=token ## api-token password=secret ## api-secret domain.example.com ## the host registered with the service. ## the host registered with the service. Example ${program}.conf file entries: ## single host update protocol=domeneshop login=username password=your-password my.example.com EoEXAMPLE } ###################################################################### ## nic_domeneshop_update ###################################################################### sub nic_domeneshop_update { debug("\nnic_domeneshop_update -------------------"); my $endpointPath = "/v0/dyndns/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 = $globals{'ssl'} ? "https://" : "http://"; $url .= "$config{$h}{'server'}$endpointPath?hostname=$h&myip=$ip"; # Try to get URL my $reply = geturl( proxy => opt('proxy'), url => $url, login => $config{$h}{'login'}, password => $config{$h}{'password'}, ); # 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); # evaluate response my @reply = split /\n/, $reply; my $status = shift(@reply); my $message = pop(@reply); if ($status =~ /204/) { $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, $status, $message); } } } ###################################################################### ## 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 ($h && $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 $ipv4 = $config{$h}{'wantipv4'}; my $ipv6 = $config{$h}{'wantipv6'}; delete $config{$_}{'wantipv4'} foreach @hosts; delete $config{$_}{'wantipv6'} foreach @hosts; info("setting IP address to %s %s for %s", $ipv4, $ipv6, $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 .= $ipv4 if $ipv4; foreach my $ipv6a ($ipv6) { $url .= "&myip="; $url .= $ipv6a } $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-ipv4'} = $status if $ipv4; $config{$h}{'status-ipv6'} = $status if $ipv6; if ($status eq 'NOERROR') { $config{$h}{'ipv4'} = $ipv4; $config{$h}{'ipv6'} = $ipv6; $config{$h}{'mtime'} = $now; success("updating %s: %s: IP address set to %s %s", $h, $status, $ipv4, $ipv6); } 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_godaddy_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_mythicdyn_examples ## ## written by Reuben Thomas ## ###################################################################### sub nic_mythicdyn_examples { return <<"EoEXAMPLE"; o 'mythicdyn' The 'mythicdyn' protocol is used by the Dynamic DNS service offered by www.mythic-beasts.com. Configuration variables applicable to the 'mythicdyn' protocol are: protocol=mythicdyn ## ipv6=no|yes ## whether to set an A record (default, ipv6=no) ## or AAAA record (ipv6=yes). 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 Note: this service automatically sets the IP address to that from which the request comes, so the IP address detected by ddclient is only used to keep track of when it needs updating. Example ${program}.conf file entries: ## Single host update. protocol=mythicdyn, \\ login=service-login \\ password=service-password, \\ host.example.com ## Multiple host update. protocol=mythicdyn, \\ login=service-login \\ password=service-password, \\ hosta.example.com,hostb.sub.example.com EoEXAMPLE } ###################################################################### ## nic_mythicdyn_update ###################################################################### sub nic_mythicdyn_update { debug("\nnic_mythicdyn_update --------------------"); # Update each set configured host. foreach my $h (@_) { info("%s -- Setting IP address.", $h); my $ipversion = $config{$h}{'ipv6'} ? '6' : '4'; my $reply = geturl( proxy => opt('proxy'), url => "https://ipv$ipversion.$config{$h}{'server'}/dns/v2/dynamic/$h", method => 'POST', login => $config{$h}{'login'}, password => $config{$h}{'password'}, ipversion => $ipversion, ); unless ($reply) { failed("Updating service %s failed: %s", $h, $config{$h}{'server'}); next; } my $ok = header_ok($h, $reply); if ($ok) { $config{$h}{'mtime'} = $now; $config{$h}{'status'} = "good"; success("%s -- Updated successfully.", $h); } else { failed("%s -- Failed to update.", $h); } } } ###################################################################### ## 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=$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 $ipv4 = delete $config{$h}{'wantipv4'}; my $ipv6 = delete $config{$h}{'wantipv6'}; info("setting IPv4 address to %s for %s", $ipv4, $h) if $ipv4; info("setting IPv6 address to %s for %s", $ipv6, $h) if $ipv6; 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=$ipv4" if $ipv4; $url .= "&ipv6=$ipv6" if $ipv6; # 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 $state = 'noresult'; my $line = ''; foreach $line (@reply) { if ($line eq 'OK') { $config{$h}{'ipv4'} = $ipv4 if $ipv4; $config{$h}{'ipv6'} = $ipv6 if $ipv6; $config{$h}{'mtime'} = $now; $config{$h}{'status'} = 'good'; $config{$h}{'status-ipv4'} = 'good' if $ipv4; $config{$h}{'status-ipv6'} = 'good' if $ipv6; $state = 'result'; success("updating %s: good: IPv4 address set to %s", $h, $ipv4) if $ipv4; success("updating %s: good: IPv6 address set to %s", $h, $ipv6) if $ipv6; } elsif ($line eq 'KO') { $config{$h}{'status'} = 'failed'; $config{$h}{'status-ipv4'} = 'failed' if $ipv4; $config{$h}{'status-ipv6'} = 'failed' if $ipv6; $state = 'result'; failed("updating %s: Server said: '%s'", $h, $line); } } if ($state eq 'noresult') { failed("updating %s: Server said: '%s'", $h, $line); } } } ###################################################################### ## 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) ## https://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 = List::Util::first { $_ =~ /good/ || $_ =~ /nochg/ } @reply; if ($returned) { $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, $reply); } } } ###################################################################### ## nic_porkbun_examples ###################################################################### sub nic_porkbun_examples { return <<"EoEXAMPLE"; o 'porkbun' The 'porkbun' protocol is used for porkbun (https://porkbun.com/). The API is documented here: https://porkbun.com/api/json/v3/documentation Before setting up, it is necessary to create your API Key by referring to the following page. https://kb.porkbun.com/article/190-getting-started-with-the-porkbun-api Available configuration variables: * apikey (required): API Key of Porkbun API * secretapikey (required): Secret API Key of Porkbun API * on-root-domain=yes or no (default: no): Indicates whether the specified domain name (FQDN) is an unnamed record (Zone APEX) in a zone. It is useful to specify it as a local variable as shown in the example. * usev4, usev6 : These configuration variables can be specified as local variables to override the global settings. It is useful to finely control IPv4 or IPv6 as shown in the example. * use (deprecated) : This parameter is deprecated but can be overridden like the above parameters. Limitations: * Multiple same name records (for round robin) are not supported. The same IP address is set for all, creating meaningless extra records. Example ${program}.conf file entry: protocol=porkbun apikey=APIKey secretapikey=SecretAPIKey host.example.com,host2.sub.example.com on-root-domain=yes example.com,sub.example.com Additional example to finely control IPv4 or IPv6 : # Example 01 : Global enable both IPv4 and IPv6, and update both records. usev4=webv4 usev6=ifv6, ifv6=enp1s0 protocol=porkbun apikey=APIKey secretapikey=SecretAPIKey host.example.com,host2.sub.example.com # Example 02 : Global enable only IPv4, and update only IPv6 record. usev4=webv4 protocol=porkbun apikey=APIKey secretapikey=SecretAPIKey usev6=ifv6, ifv6=enp1s0, usev4=disabled ipv6.example.com EoEXAMPLE } ###################################################################### ## nic_porkbun_update ###################################################################### sub nic_porkbun_update { debug("\nnic_porkbun_update -------------------"); foreach my $host (@_) { foreach my $ipv ('ipv4', 'ipv6') { my $ip = delete $config{$host}{"want$ipv"}; if (!$ip) { next; } my $rrset_type = is_ipv6($ip) ? "AAAA" : "A"; my ($sub_domain, $domain); if ($config{$host}{'on-root-domain'}) { $sub_domain = ''; $domain = $host; } else { ($sub_domain, $domain) = split(/\./, $host, 2); } info("setting %s address to %s for %s", $ipv, $ip, $host); verbose("UPDATE:","updating %s", $host); my $url = "https://porkbun.com/api/json/v3/dns/retrieveByNameType/$domain/$rrset_type/$sub_domain"; my $data = encode_json({ secretapikey => $config{$host}{'secretapikey'}, apikey => $config{$host}{'apikey'}, }); my $header = "Content-Type: application/json\n"; my $reply = geturl( proxy => opt('proxy'), url => $url, headers => $header, method => 'POST', data => $data, ); # No response, declare as failed if (!defined($reply) || !$reply) { $config{$host}{"status-$ipv"} = "bad"; failed("updating %s: Could not connect to porkbun.com.", $host); next; } if (!header_ok($host, $reply)) { $config{$host}{"status-$ipv"} = "bad"; failed("updating %s: failed (%s)", $host, $reply); next; } # Strip header # Porkbun sends data in chunks, so it is assumed to be one chunk and parsed forcibly. $reply =~ qr/{(?:[^{}]*|(?R))*}/mp; my $response = eval { decode_json(${^MATCH}) }; if (!defined($response)) { $config{$host}{"status-$ipv"} = "bad"; failed("%s -- Unexpected service response.", $host); next; } if ($response->{status} ne 'SUCCESS') { $config{$host}{"status-$ipv"} = "bad"; failed("%s -- Unexpected status. (status = %s)", $host, $response->{status}); next; } my $records = $response->{records}; if (ref($records) eq 'ARRAY' && defined $records->[0]->{'id'}) { my $count = scalar(@{$records}); if ($count > 1) { warning("updating %s: There are multiple applicable records. Only first record is used. Overwrite all with the same content."); } my $current_content = $records->[0]->{'content'}; if ($current_content eq $ip) { $config{$host}{"status-$ipv"} = "good"; success("updating %s: skipped: %s address was already set to %s.", $ipv, $host, $ip); next; } my $ttl = $records->[0]->{'ttl'}; my $notes = $records->[0]->{'notes'}; debug("ttl = %s", $ttl); debug("notes = %s", $notes); $url = "https://porkbun.com/api/json/v3/dns/editByNameType/$domain/$rrset_type/$sub_domain"; $data = encode_json({ secretapikey => $config{$host}{'secretapikey'}, apikey => $config{$host}{'apikey'}, content => $ip, ttl => $ttl, notes => $notes, }); $reply = geturl( proxy => opt('proxy'), url => $url, headers => $header, method => 'POST', data => $data, ); # No response, declare as failed if (!defined($reply) || !$reply) { failed("updating %s: Could not connect to porkbun.com.", $host); next; } if (!header_ok($host, $reply)) { failed("updating %s: failed (%s)", $host, $reply); next; } $config{$host}{"status-$ipv"} = "good"; success("updating %s: good: %s address set to %s", $ipv, $host, $ip); next; } else { $config{$host}{"status-$ipv"} = "bad"; failed("updating %s: No applicable existing records.", $host); next; } } } } 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 < opt('proxy'), url => $url); # No response, give error if (!defined($reply) || !$reply) { failed("regfish.de updating %s: failed: %s.", $h, $config{$h}{'server'}); last; } last if !header_ok($h, $reply); if ($reply =~ /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: '$reply'", $h); } } } ###################################################################### ###################################################################### ## enom ###################################################################### sub nic_enom_examples { return < opt('proxy'), url => $url ); 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; if (grep /Done=true/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); } } } sub nic_digitalocean_examples { return <<"EoEXAMPLE"; o 'digitalocean' The 'digitalocean' protocol updates domains hosted by Digital Ocean (https://www.digitalocean.com/). This protocol supports both IPv4 and IPv6. It will only update an existing record; it will not create a new one. So, before using it, make sure there's already one (and at most one) of each record type (A and/or AAAA) you plan to update present in your Digital Ocean zone. This protocol implements the API documented here: https://docs.digitalocean.com/reference/api/api-reference/. You can get your API token by following these instructions: https://docs.digitalocean.com/reference/api/create-personal-access-token/ Available configuration variables: * server (optional): API server. Defaults to 'api.digitalocean.com'. * zone (required): DNS zone under which the hostname falls. * password (required): API token from DigitalOcean Control Panel. See instructions linked above. Example ${program}.conf file entries: protocol=digitalocean, \\ zone=example.com, \\ password=api-token \\ example.com,sub.example.com EoEXAMPLE } sub nic_digitalocean_update_one { my ($h, $ip, $ipv) = @_; info("setting %s address to %s for %s", $ipv, $ip, $h); my $server = $config{$h}{'server'}; my $type = $ipv eq 'ipv6' ? 'AAAA' : 'A'; my $headers; $headers = "Content-Type: application/json\n"; $headers .= "Authorization: Bearer $config{$h}{'password'}\n"; my $list_url; $list_url = "https://$server/v2/domains/$config{$h}{'zone'}/records"; $list_url .= "?name=$h"; $list_url .= "&type=$type"; my $list_resp = geturl( proxy => opt('proxy'), url => $list_url, headers => $headers, ); unless ($list_resp && header_ok($h, $list_resp)) { $config{$h}{"status-$ipv"} = 'failed'; failed("listing %s %s: Failed connection or bad response from %s.", $h, $ipv, $server); return; } $list_resp =~ s/^.*?\n\n//s; # Strip header my $list = eval { decode_json($list_resp) }; if ($@) { $config{$h}{"status-$ipv"} = 'failed'; failed("listing %s %s: JSON decoding failure", $h, $ipv); return; } my $elem = $list; unless ((ref($elem) eq 'HASH') && (ref ($elem = $elem->{'domain_records'}) eq 'ARRAY') && (@$elem == 1 && ref ($elem = $elem->[0]) eq 'HASH')) { $config{$h}{"status-$ipv"} = 'failed'; failed("listing %s %s: no record, multiple records, or malformed JSON", $h, $ipv); return; } my $current_ip = $elem->{'data'}; my $record_id = $elem->{'id'}; if ($current_ip eq $ip) { info("updating %s %s: IP is already %s, no update needed.", $h, $ipv, $ip); } else { my $update_data = encode_json({'type' => $type, 'data' => $ip}); my $update_resp = geturl( proxy => opt('proxy'), url => "https://$server/v2/domains/$config{$h}{'zone'}/records/$record_id", method => 'PATCH', headers => $headers, data => $update_data, ); unless ($update_resp && header_ok($h, $update_resp)) { $config{$h}{"status-$ipv"} = 'failed'; failed("updating %s %s: Failed connection or bad response from %s.", $h, $ipv, $server); return; } } $config{$h}{"status-$ipv"} = 'good'; $config{$h}{"ip-$ipv"} = $ip; $config{$h}{"mtime"} = $now; } sub nic_digitalocean_update { debug("\nnic_digitalocean_update -------------------"); foreach my $h (@_) { my $ipv4 = delete $config{$h}{'wantipv4'}; my $ipv6 = delete $config{$h}{'wantipv6'}; if ($ipv4) { nic_digitalocean_update_one($h, $ipv4, 'ipv4'); } if ($ipv6) { nic_digitalocean_update_one($h, $ipv6, 'ipv6'); } } } ###################################################################### ## nic_infomaniak_examples ###################################################################### sub nic_infomaniak_examples { return <<"EoEXAMPLE"; o 'infomaniak' The 'infomaniak' protocol is used by DNS services offered by www.infomaniak.com. Configuration variables applicable to the 'infomaniak' protocol are: protocol=infomaniak login=ddns_username ## the DDNS username set up in Infomaniak password=ddns_password ## the DDNS username set up in Infomaniak example.com ## domain name to update Example ${program}.conf file entries: protocol=infomaniak, \\ login=my-username, \\ password=my-password \\ my.address.com For more information about how to create a dynamic DNS, see https://faq.infomaniak.com/2357. EoEXAMPLE } ###################################################################### ## nic_infomaniak_update ## ## written by Timothée Andres ## ## based on https://faq.infomaniak.com/2376 ## ## needs one of the following urls to update: ## https://username:password@infomaniak.com/nic/update?hostname=subdomain.yourdomain.com&myip=1.2.3.4 ## https://infomaniak.com/nic/update?hostname=subdomain.yourdomain.com&myip=1.2.3.4&username=XXX&password=XXX ###################################################################### sub nic_infomaniak_update { debug("\nnic_infomaniak_update -------------------"); foreach my $h (@_) { INFOMANIAK_IP_LOOP: foreach my $v (4, 6) { my $ip = delete $config{$h}{"wantipv$v"}; if (!defined $ip) { debug("ipv%d not wanted, skipping", $v); next; } verbose("setting IP address to %s for %s", $ip, $h); info("updating %s", $h); # No change in IP => nochg # Bad auth => badauth # Bad domain name => nohost # Bad IP => nohost # IP changed => good # No domain name => Validation failed my %statuses = ( 'good' => (1, sprintf("IP set to %s for %s", $ip, $h)), 'nochg' => (1, sprintf("IP already set to %s for %s", $ip, $h)), 'nohost' => (0, sprintf("Bad domain name %s or bad IP %s", $h, $ip)), 'badauth' => (0, sprintf("Bad authentication for %s", $h)), ); my $url1 = "https://$config{$h}{'login'}:$config{$h}{'password'}"; $url1 .= "\@infomaniak.com/nic/update"; $url1 .= "?hostname=$h"; $url1 .= "&myip=$ip"; my $url2 = "https://infomaniak.com/nic/update"; $url2 .= "?hostname=$h"; $url2 .= "&myip=$ip"; $url2 .= "&username=$config{$h}{'login'}"; $url2 .= "&password=$config{$h}{'password'}"; my $reply; foreach my $url ($url1, $url2) { verbose("trying update with %s", $url); $reply = geturl(proxy => opt('proxy'), url => $url); if (!defined($reply) || !$reply) { info("could not update %s using url %s, trying next one", $h, $url); next; } my ($status) = split / /, $reply, 1; my ($updated, $msg) = $statuses{$status} // (0, sprintf("Unknown reply from Infomaniak: %s", $reply)); if (defined $updated && $updated) { info($msg); $config{$h}{"ipv$v"} = $ip; $config{$h}{'mtime'} = $config{$h}{'mtime'} // $now; $config{$h}{'status'} = 'good'; $config{$h}{"status-ipv$v"} = 'good'; next INFOMANIAK_IP_LOOP; } else { warning($msg); } } $config{$h}{'status'} = $config{$h}{'status'} // 'failed'; $config{$h}{"status-ipv$v"} = 'failed'; failed("updating %s: could not update IP on Infomaniak", $h); } } } # Execute main() if this file is run as a script or run via PAR (https://metacpan.org/pod/PAR), # otherwise do nothing. This "modulino" pattern makes it possible to import this file as a module # and test its functions directly; there's no need for test-only command-line arguments or stdout # parsing. __PACKAGE__->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__ ddclient-3.11.2/docs/000077500000000000000000000000001452764007500143265ustar00rootroot00000000000000ddclient-3.11.2/docs/ProviderGuidelines.md000066400000000000000000000036421452764007500204600ustar00rootroot00000000000000# Provider implementations Author: [@LenardHess](https://github.com/LenardHess/)\ Date: 2023-11-23 This document is meant to detail the mechanisms that provider implementation shall use. It differentiates between new and legacy provider implementations. The former are adhering to the IPv6 support updates being done to ddclient, the legacy ones are from before that update. ## New provider Implementation 1. Grab the IP(s) from $config{$host}{'wantipv4'} and/or $config{$host}{'wantipv6'} 2. Optional: Query the provider for the current IP record(s). If they are already good, skip updating IP record(s) 3. Update the IP record(s). 4. If successful (or if the records were already good): - Set 'status-ipv4' and/or 'status-ipv6' to 'good' - Set 'ipv4' and/or 'ipv6' to the IP that has been set - Set 'mtime' to the current time 5. If not successful: - Set 'status-ipv4' and/or 'status-ipv6' to an error message - Set 'atime' to the current time The new provider implementation should not set 'status' nor 'ip'. They're part of the legacy infrastructure and ddclient will take care of setting them correctly. ## Legacy provider implementations 1. Grab the IP from $config{$host}{'wantip'} 2. Optional: Query the provider for the current IP record. If it is already good, skip updating IP record 3. Update the IP record. 4. If successful (or if the record was already good): - Set 'status' to 'good' - Set 'ip' to the IP that has been set - Set 'mtime' to the current time 5. If not successful: - Set 'status' to an error message - Set 'atime' to the current time # ToDo - Decide/Inquire whether services prefer querying the IP first. Then decide whether to make it mandatory. - Write guidelines on checking existing records (i.e. check TTL as well?). - Start a list of providers and their implementation state - Add more details to this document - Whether 'wantip*' ought to be deleted when read or not. ddclient-3.11.2/docs/ipv6-design-doc.md000066400000000000000000000376111452764007500175560ustar00rootroot00000000000000# 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. ddclient-3.11.2/m4/000077500000000000000000000000001452764007500137165ustar00rootroot00000000000000ddclient-3.11.2/m4/ax_compare_version.m4000066400000000000000000000146531452764007500200540ustar00rootroot00000000000000# =========================================================================== # 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 ddclient-3.11.2/m4/ax_prog_perl_modules.m4000066400000000000000000000043141452764007500203730ustar00rootroot00000000000000# =========================================================================== # 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 ddclient-3.11.2/m4/ax_prog_perl_version.m4000066400000000000000000000041051452764007500204060ustar00rootroot00000000000000# =========================================================================== # 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 ]) ]) ddclient-3.11.2/m4/ax_with_prog.m4000066400000000000000000000047121452764007500166560ustar00rootroot00000000000000# =========================================================================== # 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]) ]) ddclient-3.11.2/sample-ddclient-wrapper.sh000077500000000000000000000010761452764007500204640ustar00rootroot00000000000000#!/bin/bash # # This wrapper should be usefull for people who want to run a postscript with # multiple arguments. Currently ddclient has a feature which doesn't allow # multiple arguments. # This example has been written to be able to update multiple domains with # multiple login. It expects a /etc/ddclient/ddclient-domain2.conf with the # configuration of the extra domain # the second domain who has to be updated : ${SECONDCONFIG:=/etc/ddclient/ddclient-domain2.conf} # ddclient adds the new IP as argument IP=$1 ddclient -ip ${IP} -file ${SECONDCONFIG} -daemon 0 ddclient-3.11.2/sample-etc_cron.d_ddclient000066400000000000000000000014461452764007500204710ustar00rootroot00000000000000###################################################################### ## ddclient is an IP address updater for www.dyndns.org ###################################################################### ## minute 0-59 ## hour 0-23 ## day of month 1-31 ## month 1-12 (or names, see below) ## day of week 0-7 (0 or 7 is Sun, or use names) ###################################################################### ## force an update twice a month (only if you are not using daemon-mode) ## ## 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/bin/ddclient -daemon=0 -syslog -quiet retry ddclient-3.11.2/sample-etc_dhclient-exit-hooks000066400000000000000000000007521452764007500213210ustar00rootroot00000000000000#!/bin/sh ###################################################################### # 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/bin:${PATH} case "$new_ip_address" in 10.*) ;; 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 192.168.*) ;; *) logger -t dhclient IP address changed to $new_ip_address ddclient -daemon=0 -syslog -use=ip -ip=$new_ip_address >/dev/null 2>&1 ;; esac ddclient-3.11.2/sample-etc_dhcpc_dhcpcd-eth0.exe000066400000000000000000000010121452764007500214310ustar00rootroot00000000000000#!/bin/sh ###################################################################### 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 ## other interfaces are assigned private addresses from internal ## DHCP server. case "$1" in 10.*) ;; 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 192.168.*) ;; *) logger -t dhcpcd IP address changed to $1 ddclient -daemon=0 -syslog -use=ip -ip=$1 >/dev/null 2>&1 ;; esac ddclient-3.11.2/sample-etc_ppp_ip-up.local000066400000000000000000000023701452764007500204370ustar00rootroot00000000000000#!/bin/sh ###################################################################### ## ## On my host, pppd invokes this script with args: ## /etc/ppp/ip-up.local ppp0 /dev/pts/1 115200 192.168.2.1 192.168.2.3 ## ## From the manual page for my pppd, these aguments are: ## scriptname interface-name tty-device speed local-IP-address remote-IP-address ipparam ## ## Some people have reported that their pppd returns their ## local-IP-address as $3. If that's also the case for you, ## you may need to change the $4 below to $3. This may not ## be necessary if your pppd also passes the local-ip-address ## in the environment as either PPP_LOCAL or IPLOCAL. ## ###################################################################### PATH=/usr/bin:${PATH} IP= IP=${IP:-$PPP_LOCAL} IP=${IP:-$IPLOCAL} IP=${IP:-$4} IFACE= IFACE=${IFACE:-$PPP_IFACE} IFACE=${IFACE:-$1} ## update the DNS server unless the IP address is a private address ## that may be used as an internal LAN address (or PPtP tunnel). logger -t ddclient $0 $* case "$IP" in 10.*) ;; 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 192.168.*) ;; "") logger -t ddclient No local IP given so cannot update ;; *) ( sleep 5 ddclient -daemon=0 -syslog -use=if -if=$IFACE >/dev/null 2>&1 ) & ;; esac ddclient-3.11.2/sample-etc_systemd.service000066400000000000000000000003531452764007500205630ustar00rootroot00000000000000[Unit] Description=Dynamic DNS Update Client Wants=network-online.target After=network-online.target nss-lookup.target [Service] Type=forking PIDFile=/run/ddclient.pid ExecStart=/usr/bin/ddclient [Install] WantedBy=multi-user.target ddclient-3.11.2/sample-get-ip-from-fritzbox000077500000000000000000000020011452764007500205670ustar00rootroot00000000000000#!/bin/bash # # Script to fetch IP from fritzbox # # Contributed by @Rusk85 in request #45 # Script can be used in the configuration by adding # # use=cmd, cmd=/etc/ddclient/get-ip-from-fritzbox # # All credits for this one liner go to the author of this blog: # http://scytale.name/blog/2010/01/fritzbox-wan-ip # Disclaimer: It might be necessary to make the script executable # Set default hostname to connect to the FritzBox : ${FRITZ_BOX_HOSTNAME:=fritz.box} curl -s -H 'Content-Type: text/xml; charset="utf-8"' \ -H 'SOAPAction: urn:schemas-upnp-org:service:WANIPConnection:1#GetExternalIPAddress' \ -d ' ' \ "http://$FRITZ_BOX_HOSTNAME:49000/igdupnp/control/WANIPConn1" | \ grep -Eo '\<[[:digit:]]{1,3}(\.[[:digit:]]{1,3}){3}\>' ddclient-3.11.2/shell.nix000066400000000000000000000001731452764007500152260ustar00rootroot00000000000000{ pkgs ? import { } }: with pkgs; mkShellNoCC { buildInputs = [ autoconf automake gnumake ]; } ddclient-3.11.2/t/000077500000000000000000000000001452764007500136415ustar00rootroot00000000000000ddclient-3.11.2/t/get_ip_from_if.pl000066400000000000000000000054631452764007500171560ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/geturl_connectivity.pl.in000066400000000000000000000067121452764007500207110ustar00rootroot00000000000000use 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 $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 $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 = ( {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 without ssl { server_ipv => '4', client_ipv => '' }, { server_ipv => '4', client_ipv => '4' }, { server_ipv => '6', client_ipv => '' }, { server_ipv => '6', client_ipv => '6' }, # Fetch with 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' }, ); for my $tc (@test_cases) { $tc->{ipv6_opt} //= 0; $tc->{ssl} //= 0; SKIP: { 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; my $uri = $httpd{$tc->{server_ipv}}{$tc->{ssl} ? 'https' : 'http'}->endpoint(); my $name = sprintf("IPv%s client to %s%s", $tc->{client_ipv} || '*', $uri, $tc->{ipv6_opt} ? ' (-ipv6)' : ''); $ddclient::globals{'ipv6'} = $tc->{ipv6_opt}; my $got = ddclient::geturl(url => $uri, ipversion => $tc->{client_ipv}); isnt($got // '', '', $name); } } done_testing(); ddclient-3.11.2/t/is-and-extract-ipv4.pl000066400000000000000000000050611452764007500177030ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/is-and-extract-ipv6-global.pl000066400000000000000000000055111452764007500211430ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/is-and-extract-ipv6.pl000066400000000000000000000342431452764007500177110ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/lib/000077500000000000000000000000001452764007500144075ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Devel/000077500000000000000000000000001452764007500154465ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Devel/Autoflush.pm000066400000000000000000000044411452764007500177610ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test/000077500000000000000000000000001452764007500153265ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/Builder.pm000066400000000000000000001741251452764007500172640ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test/Builder/000077500000000000000000000000001452764007500167145ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/Builder/Formatter.pm000066400000000000000000000041121452764007500212130ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test/Builder/IO/000077500000000000000000000000001452764007500172235ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/Builder/IO/Scalar.pm000066400000000000000000000325101452764007500207670ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test/Builder/Module.pm000066400000000000000000000077571452764007500205170ustar00rootroot00000000000000package 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; ddclient-3.11.2/t/lib/Test/Builder/Tester.pm000066400000000000000000000431631452764007500205270ustar00rootroot00000000000000package 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; ddclient-3.11.2/t/lib/Test/Builder/Tester/000077500000000000000000000000001452764007500201625ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/Builder/Tester/Color.pm000066400000000000000000000017151452764007500216020ustar00rootroot00000000000000package 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; ddclient-3.11.2/t/lib/Test/Builder/TodoDiag.pm000066400000000000000000000020711452764007500207440ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test/More.pm000066400000000000000000001467311452764007500166020ustar00rootroot00000000000000package 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; ddclient-3.11.2/t/lib/Test/Simple.pm000066400000000000000000000145341452764007500171240ustar00rootroot00000000000000package 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; ddclient-3.11.2/t/lib/Test/Tester.pm000066400000000000000000000436351452764007500171450ustar00rootroot00000000000000use 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 ddclient-3.11.2/t/lib/Test/Tester/000077500000000000000000000000001452764007500165745ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/Tester/Capture.pm000066400000000000000000000105101452764007500205320ustar00rootroot00000000000000use 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 ddclient-3.11.2/t/lib/Test/Tester/CaptureRunner.pm000066400000000000000000000024261452764007500217330ustar00rootroot00000000000000# $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 ddclient-3.11.2/t/lib/Test/Tester/Delegate.pm000066400000000000000000000010731452764007500206450ustar00rootroot00000000000000use 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; ddclient-3.11.2/t/lib/Test/use/000077500000000000000000000000001452764007500161225ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test/use/ok.pm000066400000000000000000000025201452764007500170700ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2.pm000066400000000000000000000143711452764007500157540ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/000077500000000000000000000000001452764007500154105ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/API.pm000066400000000000000000001371571452764007500163750ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/API/000077500000000000000000000000001452764007500160215ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/API/Breakage.pm000066400000000000000000000113321452764007500200600ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/API/Context.pm000066400000000000000000000656011452764007500200130ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/API/Instance.pm000066400000000000000000000517711452764007500201360ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/API/Stack.pm000066400000000000000000000113761452764007500174340ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event.pm000066400000000000000000000541571452764007500170430ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/000077500000000000000000000000001452764007500164715ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Event/Bail.pm000066400000000000000000000032401452764007500176750ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Diag.pm000066400000000000000000000026571452764007500177050ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Encoding.pm000066400000000000000000000033511452764007500205570ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Exception.pm000066400000000000000000000033651452764007500207740ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Fail.pm000066400000000000000000000037421452764007500177100ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Generic.pm000066400000000000000000000134251452764007500204100ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Note.pm000066400000000000000000000026111452764007500177340ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Ok.pm000066400000000000000000000055231452764007500174050ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Pass.pm000066400000000000000000000036161452764007500177430ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Plan.pm000066400000000000000000000064741452764007500177340ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Skip.pm000066400000000000000000000037321452764007500177420ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Subtest.pm000066400000000000000000000061751452764007500204710ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/TAP/000077500000000000000000000000001452764007500171155ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Event/TAP/Version.pm000066400000000000000000000031541452764007500211030ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/V2.pm000066400000000000000000000113671452764007500173260ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Event/Waiting.pm000066400000000000000000000023261452764007500204340ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet.pm000066400000000000000000000027261452764007500200010ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/000077500000000000000000000000001452764007500174345ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/EventFacet/About.pm000066400000000000000000000027141452764007500210500ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Amnesty.pm000066400000000000000000000031531452764007500214140ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Assert.pm000066400000000000000000000032601452764007500212340ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Control.pm000066400000000000000000000037301452764007500214150ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Error.pm000066400000000000000000000034131452764007500210640ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Hub.pm000066400000000000000000000035251452764007500205150ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Info.pm000066400000000000000000000060661452764007500206750ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Info/000077500000000000000000000000001452764007500203275ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/EventFacet/Info/Table.pm000066400000000000000000000054471452764007500217260ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Meta.pm000066400000000000000000000035061452764007500206640ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Parent.pm000066400000000000000000000033261452764007500212270ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Plan.pm000066400000000000000000000035361452764007500206730ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Render.pm000066400000000000000000000037771452764007500212270ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/EventFacet/Trace.pm000066400000000000000000000136711452764007500210400ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Formatter.pm000066400000000000000000000075611452764007500177220ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Formatter/000077500000000000000000000000001452764007500173535ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Formatter/TAP.pm000066400000000000000000000326441452764007500203460ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Hub.pm000066400000000000000000000543621452764007500164760ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Hub/000077500000000000000000000000001452764007500161265ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Hub/Interceptor.pm000066400000000000000000000026311452764007500207640ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Hub/Interceptor/000077500000000000000000000000001452764007500204245ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Hub/Interceptor/Terminator.pm000066400000000000000000000013401452764007500231040ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Hub/Subtest.pm000066400000000000000000000051201452764007500201130ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/IPC.pm000066400000000000000000000061461452764007500163700ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/IPC/000077500000000000000000000000001452764007500160235ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/IPC/Driver.pm000066400000000000000000000145721452764007500176250ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/IPC/Driver/000077500000000000000000000000001452764007500172565ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/IPC/Driver/Files.pm000066400000000000000000000323671452764007500206710ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Tools/000077500000000000000000000000001452764007500165105ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Tools/Tiny.pm000066400000000000000000000216651452764007500200030ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Util.pm000066400000000000000000000244041452764007500166670ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Util/000077500000000000000000000000001452764007500163255ustar00rootroot00000000000000ddclient-3.11.2/t/lib/Test2/Util/ExternalMeta.pm000066400000000000000000000073031452764007500212570ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Util/Facets2Legacy.pm000066400000000000000000000153731452764007500213100ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Util/HashBase.pm000066400000000000000000000316451452764007500203520ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/Test2/Util/Trace.pm000066400000000000000000000015231452764007500177220ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/lib/ddclient/000077500000000000000000000000001452764007500161755ustar00rootroot00000000000000ddclient-3.11.2/t/lib/ddclient/Test/000077500000000000000000000000001452764007500171145ustar00rootroot00000000000000ddclient-3.11.2/t/lib/ddclient/Test/Fake/000077500000000000000000000000001452764007500177625ustar00rootroot00000000000000ddclient-3.11.2/t/lib/ddclient/Test/Fake/HTTPD.pm000066400000000000000000000205131452764007500212040ustar00rootroot00000000000000# 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 ddclient-3.11.2/t/lib/ddclient/Test/Fake/HTTPD/000077500000000000000000000000001452764007500206455ustar00rootroot00000000000000ddclient-3.11.2/t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem000066400000000000000000000103521452764007500240200ustar00rootroot00000000000000Certificate: 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----- ddclient-3.11.2/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem000066400000000000000000000213241452764007500247440ustar00rootroot00000000000000Certificate: 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----- ddclient-3.11.2/t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem000066400000000000000000000032541452764007500246010ustar00rootroot00000000000000-----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----- ddclient-3.11.2/t/lib/ddclient/t.pm000066400000000000000000001032171452764007500170020ustar00rootroot00000000000000package 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", }, ); ddclient-3.11.2/t/lib/ok.pm000066400000000000000000000017071452764007500153630ustar00rootroot00000000000000package 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 ddclient-3.11.2/t/parse_assignments.pl000066400000000000000000000055371452764007500177350ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/version.pl.in000066400000000000000000000003731452764007500162730ustar00rootroot00000000000000use 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(); ddclient-3.11.2/t/write_cache.pl000066400000000000000000000030541452764007500164550ustar00rootroot00000000000000use 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();