Net-Ident-1.31/000755 000765 000024 00000000000 15163570205 014755 5ustar00todd.rinaldostaff000000 000000 Net-Ident-1.31/cpanfile000644 000765 000024 00000000257 15160057031 016457 0ustar00todd.rinaldostaff000000 000000 requires 'Socket'; requires 'FileHandle'; requires 'Carp'; requires 'Errno'; requires 'Exporter'; on 'test' => sub { requires 'Test::More'; requires 'IO::Socket'; }; Net-Ident-1.31/Changes000644 000765 000024 00000016011 15163570110 016242 0ustar00todd.rinaldostaff000000 000000 Revision history for Perl extension Net::Ident. 1.31 2026-04-02 [Improvements] - PR #43 - Add functional tests for lookupFromInAddr() and lookup() covering scalar/list context, error propagation, unreachable remotes, bad filehandles, and the ident_lookup alias - PR #44 - Add timeout behavior tests for query() and ready() covering expired timeouts, select() timeout, partial data accumulation, timeout propagation through username(), and non-blocking ready() [Maintenance] - PR #38 - Add missing patterns to MANIFEST.SKIP (blib/, pm_to_blib, Makefile.old, dist directories, .tar.gz files) - PR #39 - Add AI policy (AI_POLICY.md) and link from README - PR #40 - Remove dead Apache/mod_perl infrastructure from Makefile.PL, reducing it from 660 lines to 44 - PR #41 - Clean up POD warnings and remove dead compat-mode markers - PR #42 - Remove stale INSTALL file and fix MANIFEST inconsistency 1.29 2026-03-24 [Improvements] - PR #36 - Add constructor tests for new() and _passfh resolution covering glob ref, string, qualified name, FileHandle, error-state objects, newFromInAddr, and connected socket without identd [Maintenance] - PR #35 - Regenerate README.md from current POD to pick up badge, example code, and typo fixes - PR #37 - Fix .gitignore to match all dist directories, not just 0.x 1.28 2026-03-22 [Bug Fixes] - GH #26, PR #33 - Handle ECONNRESET from sysread on Windows where socketpair emulation sends TCP RST instead of FIN on close - GH #28, PR #31 - Handle ESPIPE from sysread on Solaris socketpairs where remote close returns "Illegal seek" instead of EOF - GH #29, PR #30 - Add use 5.010 to remaining test files for Perl 5.8.x defense in depth [Maintenance] - PR #25 - Add use 5.010 to Makefile.PL for clean failure on old perls - PR #34 - Sync cpanfile and PREREQ_PM with actual dependencies: remove unused Fcntl and Config, add missing Errno 1.27 2026-03-20 [Bug Fixes] - GH #19, PR #23 - Remove select() exception mask checks that fail on Solaris - GH #20, PR #24 - Remove select() exception mask that fails on Solaris socketpair - GH #18, PR #22 - Add use 5.010 for clean failure on Perl < 5.10 - GH #17, PR #21 - Make t/query.t portable to Windows [Improvements] - PR #15 - Add comprehensive tests for export hook mechanism [Maintenance] - PR #16 - Improve CPAN metadata in Makefile.PL (LICENSE, MIN_PERL_VERSION, TEST_REQUIRES, META spec v2) 1.26 2026-03-18 [Bug Fixes] - GH #2 - Fix compat mode - GH #12 - Fix sysread EOF in ready() to prevent infinite loop - GH #9 - Fix unreachable elsif in ready() that broke repeated calls - GH #10 - Fix SUPER::export_fail to use method call so class is passed correctly - GH #11 - Fix newFromInAddr state inconsistency [Improvements] - GH #14 - Replace string eval with blocking(0) for non-blocking sockets - GH #8 - Add unit tests for RFC1413 response parsing - GH #13 - Add comprehensive async interface tests - GH #10 - Modernize tests from hand-rolled TAP to Test::More [Maintenance] - GH #3 - Fix Makefile.PL bugs, fix pod typos - GH #11 - Fix POD example and typos - GH #7 - Modernize CI: consolidate workflows, fix deprecated Docker images - GH #4 - Update repository URLs to reflect new cpan-authors location 1.25 Sat Jan 18 2020 - Enable github actions testing - Switch to README.md and point to testing status - Fix spelling typo provided by Debian project - Switch primary tracker to github issues - Remove META.yml from source control 1.24 Sun Dec 14 2014 - RT 79165 - Fix for Strawberry Perl - Tidy code base for conformity of future patches 1.23 Sun Jun 13 2010 - Setting values for read only tied hash %! is illegal. removing code. 1.22 Fri Jun 11 09:00:00 CST 2010 - Remove Apache (mod_perl) as a dep for this module 1.21 Fri Jun 11 01:00:00 CST 2010 - Move sub around to fix prototyping bug. - Remove broken ident hosts from list so tests don't break. Right now i know of no working public ident hosts. Patches welcome! - Update Makefile.PL with new options - Add META.yml to module - use %! to determine if error was EINPROGRESS to function in other languages 1.20 Fri Aug 27 00:59:24 CEST 1999 - Public release - Added a few more apache layouts to the Makefile.PL to autodetect. 1.19 Mon Aug 2 22:50:21 CEST 1999 - Added the often asked for, long promised lookupFromInaddr method. - No longer imports ident_lookup into package FileHandle by default, unless you explicitly ask for it (or unless you installed it that way during compile time for compatibility reasons). - Allow adding an ident_lookup method to the Apache::Connection class, as a convenience for mod_perl script writers. - Rewritten tests, included test for the Apache::Connection method by actually launching apache and performing ident lookups from within mod_perl. - Moved selection of FileHandle/IO::Handle class out of the Makefile.PL. PAUSE/CPAN didn't really like modules that weren't present in the distribution, and it didn't allow you to upgrade your perl version underneath. 1.11 Wed Jan 15 01:49:15 MET 1999 - Several bugfixes, and some slight interface changes: - constructor now called `new' instead of `initconnect', constructor now always succeeds, if something has gone wrong in the constructor, all methods return undef (like `getfh'), except for `geterror', which returns the error message. - The recommended exported function is now `ident_lookup' instead of `lookup' - Fixed a bug: now chooses O_NDELAY or O_NONBLOCK from %Config, instead of hardcoding O_NDELAY (argh) - Adding a method to FileHandle would break in perl5.004, it should get added in IO::Handle. Added intelligence in Makefile.PL to detect that and choose the appropriate package. - Miscellaneous pod fixes. - Test script now actually tests multiple different things. 1.10 Sat Jan 11 19:05:35 1997 - original version; created by h2xs 1.16. First release as a perl5 module, complete rewrite for perl5, based on rfc931.pl 1.02 Fri Jan 20 18:20:32 1995 - Quite a big bugfix: "connection refused" to the ident port would kill the perl process with a SIGPIPE if the connect didn't immediately signal it (ie. almost always on remote machines). Also recognises the perl5 package separator :: now on fully qualified descriptors. This is still perl4-compatible, a perl5- only version would require a rewrite to make it neater. Fixed the constants normally found in .ph files (but you shouldn't use those anyway). 1.01 Some Novish evening 1994 - Removed a spurious perl5 -w complaint. First public release. Has been tested against perl 5.000 and perl 4.036. 1.00 Somewhere in 1994 - First neat collection of dusty routines put in a package. Net-Ident-1.31/MANIFEST000644 000765 000024 00000001776 15163570205 016121 0ustar00todd.rinaldostaff000000 000000 .perltidyrc AI_POLICY.md Changes revision history cpanfile Ident.pm the module itself, contains pod Makefile.PL feed to perl to get a makefile MANIFEST README.md extract of the manpage, gives a brief overview t/0use.t script to test "use Net::Ident" t/async.t tests for async non-blocking interface t/compat.t script to test compatibility-mode FH->ident_lookup t/constructor.t tests for new() and _passfh filehandle resolution t/export.t tests for export hooks (:fh, :apache, :debug tags) t/hosts Hosts to use for testing purposes t/Ident.t test script that actually makes ident lookups t/lookup.t tests for lookup() and lookupFromInAddr() functions t/parse.t unit tests for RFC1413 response parsing t/query.t unit tests for query() method and end-to-end flow t/timeout.t tests for timeout behavior in query() and ready() META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Net-Ident-1.31/AI_POLICY.md000644 000765 000024 00000013036 15161537065 016657 0ustar00todd.rinaldostaff000000 000000 # AI Policy > **TL;DR** — AI tools assist our workflow at every stage. Humans remain in control of every decision, every review, and every release. --- ## Overview This document describes how artificial intelligence tools are used in the maintenance and development of this project. It is intended to be transparent with our contributors, users, and the broader open-source community about the role AI plays — and, equally importantly, the role it does **not** play. We believe in honest, clear communication about AI-assisted workflows. This policy will be updated as our practices evolve. --- ## Our Guiding Principle **AI assists. Humans decide.** The maintainers who have been stewarding this project for years remain fully responsible for every line of code that ships. AI tools extend our capacity to review, research, and improve — they do not replace human judgment, expertise, or accountability. --- ## How AI Is Used in This Project ### 1. Code and Issue Analysis AI tools help us process and understand incoming issues, pull requests, and code changes at scale. This includes: - Summarising issue reports and identifying patterns across similar bugs - Analysing code diffs for potential problems, regressions, or style inconsistencies - Surfacing relevant context from the codebase, documentation, and prior discussions - Flagging potential security concerns for human review This analysis is **always** used as input to human decision-making, never as a substitute for it. ### 2. Draft Pull Requests AI may generate draft pull requests as a starting point for a fix, a refactor, or an improvement. These drafts: - Are clearly labelled as AI-generated when created - Represent a first pass only — they are never considered complete or correct without human review - May be substantially reworked, rejected, or replaced entirely by maintainers Think of these drafts the way you would think of a junior contributor's first attempt: useful raw material that still needs experienced eyes. ### 3. Human Review of Every Pull Request **Every pull request — whether AI-drafted or human-authored — is reviewed by a human maintainer before it can be merged.** During review, maintainers actively use AI as a tool to assist their own thinking: - Asking AI to explain or justify specific implementation choices - Challenging AI-generated code and requesting alternative approaches - Using AI to research edge cases, relevant standards, or upstream behaviour - Requesting targeted rewrites of individual sections based on review feedback The maintainer's judgment always takes precedence. AI answers are treated as input to be verified, not conclusions to be accepted. ### 4. Test Coverage and Defect Detection AI helps us improve the quality and completeness of our test suite by: - Suggesting test cases for edge conditions and failure modes - Identifying gaps in existing test coverage - Proposing tests that target known classes of defects or security issues - Helping reproduce and characterise reported bugs All suggested tests are reviewed and validated by maintainers before being committed. ### 5. Security Review AI tools assist in identifying potential security issues, including: - Common vulnerability patterns (injection, insecure defaults, deprecated APIs, etc.) - Dependencies with known CVEs - Code paths that may warrant closer scrutiny Security findings from AI are **always** verified by a human maintainer. We do not act on AI-flagged security issues without independent assessment. --- ## What AI Does Not Do To be explicit about the limits of AI involvement in this project: | ❌ AI does not… | ✅ A human maintainer does… | |---|---| | Approve or merge pull requests | Review and decide on every PR | | Make architectural decisions | Own all design and direction choices | | Triage and close issues autonomously | Assess and respond to all issues | | Publish releases | Tag, build, and release manually | | Represent the project publicly | Communicate on behalf of the project | --- ## Releases Releases are performed manually by the same long-standing maintainers as always. The release process — including changelog review, version tagging, and publication — uses standard Perl ecosystem tooling (e.g. ExtUtils::MakeMaker, Dist::Zilla, Module::Build) but involves no AI-driven automation. Every release is initiated, supervised, and published by a human maintainer. AI may assist in drafting changelogs or release notes, but these are always reviewed and edited before publication. --- ## Attribution and Transparency Where AI has played a material role in generating code or content within a pull request, we aim to note this in the PR description (e.g. via a `Generated-By` or `AI-Assisted` label or note). We do not consider AI the author of any contribution — the maintainer who reviewed and approved the work takes responsibility for it. --- ## Why We Do This Open-source software is built on trust. Our users and downstream dependants trust us to ship correct, secure, and well-considered code. AI tools help us do that work better — but they do not change who is responsible for the outcome. We use AI because it makes our maintainers more effective, not because it replaces them. --- ## Questions and Feedback If you have questions about our use of AI, or concerns about a specific pull request or change, please open an issue or start a discussion. We are committed to being open about our process. --- *Last updated: 2026-03-23* *This policy is maintained by the project maintainers and subject to revision as AI tooling and community norms evolve.* Net-Ident-1.31/t/000755 000765 000024 00000000000 15163570205 015220 5ustar00todd.rinaldostaff000000 000000 Net-Ident-1.31/README.md000644 000765 000024 00000037573 15163570042 016252 0ustar00todd.rinaldostaff000000 000000 [![testsuite](https://github.com/cpan-authors/Net-Ident/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/Net-Ident/actions/workflows/testsuite.yml) # NAME Net::Ident - lookup the username on the remote end of a TCP/IP connection # SYNOPSIS use Net::Ident; $username = Net::Ident::lookup(SOCKET, $timeout); $username = Net::Ident::lookupFromInAddr($localsockaddr, $remotesockaddr, $timeout); $obj = Net::Ident->new(SOCKET, $timeout); $obj = Net::Ident->newFromInAddr($localsockaddr, $remotesockaddr, $timeout); $status = $obj->query; $status = $obj->ready; $username = $obj->username; ($username, $opsys, $error) = $obj->username; $fh = $obj->getfh; $txt = $obj->geterror; use Net::Ident 'ident_lookup'; $username = ident_lookup(SOCKET, $timeout); use Net::Ident 'lookupFromInAddr'; $username = lookupFromInAddr($localsockaddr, $remotesockaddr, $timeout); use Net::Ident ':fh'; $username = SOCKET->ident_lookup($timeout); use Net::Ident ':apache'; # my Apache $r; $c = $r->connection; $username = $c->ident_lookup($timeout); # OVERVIEW **Net::Ident** is a module that looks up the username on the remote side of a TCP/IP connection through the ident (auth/tap) protocol described in RFC1413 (which supersedes RFC931). Note that this requires the remote site to run a daemon (often called **identd**) to provide the requested information, so it is not always available for all TCP/IP connections. # DESCRIPTION You can either use the simple interface, which does one ident lookup at a time, or use the asynchronous interface to perform (possibly) many simultaneous lookups, or simply continue serving other things while the lookup is proceeding. ## Simple Interface The simple interface comes in four varieties. An object oriented method call of a FileHandle object, an object oriented method of an Apache::Connection object, and as one of two different simple subroutine calls. Other than the calling method, these routines behave exactly the same. - `Net::Ident::lookup (SOCKET` \[`, $timeout`\]`)` **Net::Ident::lookup** is an exportable function. However, due to the generic name of the **lookup** function, it is recommended that you instead import the alias function **Net::Ident::ident\_lookup**. Both functions are exported through `@EXPORT_OK`, so you'll have to explicitly ask for it if you want the function **ident\_lookup** to be callable from your program. You can pass the socket using either a string, which doesn't have to be qualified with a package name, or using the more modern FileHandle calling styles: as a glob or as a reference to a glob. The Socket has to be a connected TCP/IP socket, ie. something which is either **connect()**ed or **accept()**ed. The optional timeout parameter specifies a timeout in seconds. If you do not specify a timeout, or use a value of undef, there will be no timeout (apart from any default system timeouts like TCP connection timeouts). - `Net::Ident::lookupFromInAddr ($localaddr, $remoteaddr` \[`, $timeout`\]`)` **Net::Ident::lookupFromInAddr** is an exportable function (via `@EXPORT_OK`). The arguments are the local and remote address of a connection, in packed \`\`sockaddr'' format (the kind of thing that `getsockname` returns). The optional timeout value specifies a timeout in seconds, see also the description of the timeout value in the `Net::Ident::lookup` section above. The given localaddr **must** have the IP address of a local interface of the machine you're calling this on, otherwise an error will occur. You can use this function whenever you have a local and remote socket address, but no direct access to the socket itself. For example, because you are parsing the output of "netstat" and extracting socket address, or because you are writing a mod\_perl script under apache (in that case, also see the Apache::Connection method below). - `ident_lookup SOCKET` \[`$timeout`\] When you import the \`\`magic'' tag ':fh' using `use Net::Ident ':fh';`, the **Net::Ident** module extends the **FileHandle** class with one extra method call, **ident\_lookup**. It assumes that the object (a FileHandle) it is operating on, is a connected TCP/IP socket, ie. something which is either **connect()**ed or **accept()**ed. The optional parameter specifies the timeout in seconds, just like the timeout parameter of the function calls above. Some people do not like the way that \`\`proper'' object design is broken by letting one module add methods to another class. This is why, starting from version 1.20, you have to explicitly ask for this behaviour to occur. Personally, I think it's a compromise: if you want an object-oriented interface, then either you make a derived class, like a FileHandleThatCanPerformIdentLookups, and make sure all appropriate internal functions get wrappers that do the necessary re-blessing. Or, you simply extend the FileHandle class. And since Perl doesn't object to this (pun intended :), I find this an acceptable solution. But you might think otherwise. - `ident_lookup Apache::Connection` \[`$timeout`\] When you import the \`\`magic'' tag ':apache' using `use Net::Ident ':apache';`, the **Net::Ident** module extends the **Apache::Connection** class with one extra method call, **ident\_lookup**. This method takes one optional parameter: a timeout value in seconds. This is a similar convenience function as the FileHandle::ident\_lookup method, to be used with mod\_perl scripts under Apache. What these functions return depends on the context: - scalar context In scalar context, these functions return the remote username on success, or undef on error. "Error" is rather broad, it might mean: some network error occurred, function arguments are invalid, the remote site is not responding (in time) or is not running an ident daemon, or the remote site ident daemon says there's no user connected with that particular connection. More precisely, the functions return whatever the remote daemon specified as the ID that belongs to that particular connection. This is often the username, but it doesn't necessarily have to be. Some sites, out of privacy and/or security measures, return an opaque ID that is unique for each user, but is not identical to the username. See _RFC1413_ for more information. - array context In array context, these functions return: `($username, $opsys, $error)`. The _$username_ is the remote username or ID, as returned in the scalar context, or undef on error. The _$opsys_ is the remote operating system as reported by the remote ident daemon, or undef on a network error, or **"ERROR"** when the remote ident daemon reported an error. This could also contain the character set of the returned username. See RFC1413. The _$error_ is the error message, either the error reported by the remote ident daemon (in which case _$opsys_ is **"ERROR"**), or the internal message from the **Net::Ident** module, which includes the system errno `$!` whenever possible. A likely candidate is **"Connection refused"** when the remote site isn't running an ident daemon, or **"Connection timed out"** when the remote site isn't answering our connection request. When _$username_ has a value, _$error_ is always undef, and vice versa. ## EXAMPLE The following code is a complete example, implementing a server that waits for a connection on a port, tells you who you are and what time it is, and closes the connection again. The majority of the code will look very familiar if you just read [perlipc](https://metacpan.org/pod/perlipc). Exercise this server by telnetting to it, preferably from a machine that has a suitable ident daemon installed. #!/usr/bin/perl -w use Net::Ident ':fh'; # uncomment the below line if you want lots of debugging info # $Net::Ident::DEBUG = 2; use Socket; use strict; sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } my $port = shift || 2345; my $proto = getprotobyname('tcp'); socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "setsockopt: $!"; bind(Server, sockaddr_in($port, INADDR_ANY)) or die "bind: $!"; listen(Server,SOMAXCONN) or die "listen: $!"; logmsg "server started on port $port"; my $paddr; for ( ; $paddr = accept(Client,Server); close Client) { my($port,$iaddr) = sockaddr_in($paddr); my $name = gethostbyaddr($iaddr,AF_INET) || inet_ntoa($iaddr); logmsg "connection from $name [" . inet_ntoa($iaddr) . "] at port $port"; my $username = Client->ident_lookup(30) || "~unknown"; logmsg "User at $name:$port is $username"; print Client "Hello there, $username\@$name, it's now ", scalar localtime, "\n"; } ## Asynchronous Interface The asynchronous interface is meant for those who know the ins and outs of the `select()` call (the 4-argument version of `select()`, but I didn't need saying that, did I?). This interface is completely object oriented. The following methods are available: - `new Net::Ident SOCKET, $timeout` This constructs a new Net::Ident object, and initiates the connection to the remote ident daemon. The parameters are the same as described above for the **Net::Ident::lookup** subroutine. This method returns immediately, the supplied _$timeout_ is only stored in the object and used in future methods. If you want to implement your own timeout, that's fine. Simply throw away the object when you don't want it anymore. The constructor will always succeed. When it detects an error, however, it returns an object that "has already failed" internally. In this case, all methods will return `undef` except for the `geterror` method, which will return the error message. The timeout is _not_ implemented using `alarm()`. In fact you can use `alarm()` completely independent of this library, they do not interfere. - `newFromInAddr $localaddr, $remoteaddr, $timeout` Alternative constructor, that takes two packed sockaddr structures. Otherwise behaves identical to the `new` constructor above. - `query $obj` This object method queries the remote rfc931 daemon, and blocks until the connection to the ident daemon is writable, if necessary (but you are supposed to make sure it is, of course). Returns true on success (or rather it returns the _$obj_ itself), or undef on error. - `ready $obj` \[`$blocking`\] This object method returns whether the data received from the remote daemon is complete (true or false). Returns undef on error. Reads any data from the connection. If _$blocking_ is true, it blocks and waits until all data is received (it never returns false when blocking is true, only true or undef). If _$blocking_ is not true, it doesn't block at all (unless... see below). If you didn't call `query $obj` yet, this method calls it for you, which means it _can_ block, regardless of the value of _$blocking_, depending on whether the connection to the ident is writable. Obviously, you are supposed to call this routine whenever you see that the connection to the ident daemon is readable, and act appropriately when this returns true. Note that once **ready** returns true, there are no longer checks on timeout (because the networking part of the lookup is over anyway). This means that even `ready $obj` can return true way after the timeout has expired, provided it returned true at least once before the timeout expired. This is to be construed as a feature. - `username $obj` This object method parses the return from the remote ident daemon, and blocks until the query is complete, if necessary (it effectively calls `ready $obj 1` for you if you didn't do it yourself). Returns the parsed username on success, or undef on error. In an array context, the return values are the same as described for the **Net::Ident::lookup** subroutine. - `getfh $obj` This object method returns the internal FileHandle used for the connection to the remote ident daemon. Invaluable if you want it to dance in your select() ring. Returns undef when an error has occurred. - `geterror $obj` This object method returns the error message in case there was an error. undef when there was no error. An asynchronous example implementing the above server in a multi-threaded way via select, is left as an exercise for the interested reader. # DISCLAIMER I make NO WARRANTY or representation, either express or implied, with respect to this software, its quality, accuracy, merchantability, or fitness for a particular purpose. This software is provided "AS IS", and you, its user, assume the entire risk as to its quality and accuracy. # AUTHOR Jan-Pieter Cornet, # COPYRIGHT Copyright (c) 1995, 1997, 1999 Jan-Pieter Cornet. All rights reserved. You can distribute and use this program under the same terms as Perl itself. # REVISION HISTORY - V1.20 August 2, 1999. Finally implemented the long-asked-for lookupFromInAddr method. Other changes: - No longer imports ident\_lookup into package FileHandle by default, unless you explicitly ask for it (or unless you installed it that way during compile time for compatibility reasons). - Allow adding an ident\_lookup method to the Apache::Connection class, as a convenience for mod\_perl script writers. - Rewritten tests, included test for the Apache::Connection method by actually launching apache and performing ident lookups from within mod\_perl. - Moved selection of FileHandle/IO::Handle class out of the Makefile.PL. PAUSE/CPAN didn't really like modules that weren't present in the distribution, and it didn't allow you to upgrade your perl version underneath. - V1.11 Jan 15th, 1997. Several bugfixes, and some slight interface changes: - constructor now called `new` instead of `initconnect`, constructor now always succeeds, if something has gone wrong in the constructor, all methods return undef (like `getfh`), except for `geterror`, which returns the error message. - The recommended exported function is now `ident_lookup` instead of `lookup` - Fixed a bug: now chooses O\_NDELAY or O\_NONBLOCK from %Config, instead of hardcoding O\_NDELAY (argh) - Adding a method to FileHandle would break in perl5.004, it should get added in IO::Handle. Added intelligence in Makefile.PL to detect that and choose the appropriate package. - Miscellaneous pod fixes. - Test script now actually tests multiple different things. - V1.10 Jan 11th, 1997. Complete rewrite for perl5. Requires perl5.002 or up. - V1.02 Jan 20th, 1995. Quite a big bugfix: "connection refused" to the ident port would kill the perl process with a SIGPIPE if the connect didn't immediately signal it (ie. almost always on remote machines). Also recognises the perl5 package separator :: now on fully qualified descriptors. This is still perl4-compatible, a perl5- only version would require a rewrite to make it neater. Fixed the constants normally found in .ph files (but you shouldn't use those anyway). \[this release wasn't called **Net::Ident**, of course, it was called **rfc931.pl**\] - V1.01 Around November 1994. Removed a spurious **perl5 -w** complaint. First public release. Has been tested against **perl 5.000** and **perl 4.036**. - V1.00 Dunno, somewhere 1994. First neat collection of dusty routines put in a package. # SEE ALSO [Socket](https://metacpan.org/pod/Socket) RFC1413, RFC931 Net-Ident-1.31/Ident.pm000644 000765 000024 00000104144 15163570111 016356 0ustar00todd.rinaldostaff000000 000000 package Net::Ident; use 5.010; use strict; use warnings; use Socket; use FileHandle; use Carp; use Errno; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(ident_lookup lookup lookupFromInAddr); our @EXPORT_FAIL; our %EXPORT_TAGS; # EXPORT_HOOKS is a sortof Exporter extension. Whenever one of the keys # of this hash is imported as a "tag", the corresponding function is called our %EXPORT_HOOKS = ( 'fh' => \&_add_fh_method, 'apache' => \&_add_apache_method, 'debug' => \&_set_debug, ); # provide import magic sub _export_hooks () { my ( $tag, $hook ); while ( ( $tag, $hook ) = each %EXPORT_HOOKS ) { my $hookname = "_export_hook_$tag"; # pseudo-function name $EXPORT_TAGS{$tag} = [$hookname]; push @EXPORT_OK, $hookname; push @EXPORT_FAIL, $hookname; } } # put the export hooks in the standard Exporter structures _export_hooks(); # for compatibility mode, uncomment the next line # our @EXPORT = qw(_export_hook_fh); our $VERSION = "1.31"; our $DEBUG = 0; *STDDBG = *STDERR; sub _set_debug { $DEBUG++; print STDDBG "Debugging turned to level $DEBUG\n"; } # protocol number for tcp. my $tcpproto = ( getprotobyname('tcp') )[2] || 6; # get identd port (default to 113). my $identport = ( getservbyname( 'ident', 'tcp' ) )[2] || 113; # turn a filehandle passed as a string, or glob, into a ref # private subroutine sub _passfh ($) { my ($fh) = @_; # test if $fh is a reference. if it's not, we need to process... if ( !ref $fh ) { print STDDBG "passed fh: $fh is not a reference\n" if $DEBUG; # check for fully qualified name if ( $fh !~ /'|::/ ) { print STDDBG "$fh is not fully qualified\n" if $DEBUG; # get our current package my $mypkg = (caller)[0]; print STDDBG "We are package $mypkg\n" if $DEBUG; # search for calling package my $depth = 1; my $otherpkg; $depth++ while ( ( $otherpkg = caller($depth) ) eq $mypkg ); print STDDBG "We are called from package $otherpkg\n" if $DEBUG; $fh = "${otherpkg}::$fh"; print STDDBG "passed fh now fully qualified: $fh\n" if $DEBUG; } # turn $fh into a reference to a $fh. we need to disable strict refs no strict 'refs'; $fh = \*{$fh}; } $fh; } # create a Net::Ident object, and perform a non-blocking connect() # to the remote identd port. # class method, constructor sub new { my ( $class, $fh, $timeout ) = @_; my ( $localaddr, $remoteaddr ); print STDDBG "Net::Ident::new fh=$fh, timeout=" . ( defined $timeout ? $timeout : "" ) . "\n" if $DEBUG > 1; # "try" eval { defined $fh or die "= fh undef\n"; $fh = _passfh($fh); # get information about this (the local) end of the connection. We # assume that $fh is a connected socket of type SOCK_STREAM. If # it isn't, you'll find out soon enough because one of these functions # will return undef real fast. $localaddr = getsockname($fh) or die "= getsockname failed: $!\n"; # get information about remote end of connection $remoteaddr = getpeername($fh) or die "= getpeername failed: $!\n"; }; if ( $@ =~ /^= (.*)/ ) { # here's the catch of the throw # return false, try to preserve errno local ($!); # we make a "fake" $self my $self = { 'state' => 'error', 'error' => "Net::Ident::new: $1\n", }; print STDDBG $self->{error} if $DEBUG; # return our blessed $self return bless $self, $class; } elsif ($@) { # something else went wrong. barf up completely. confess($@); } # continue with the NewFromInAddr constructor $class->newFromInAddr( $localaddr, $remoteaddr, $timeout ); } sub newFromInAddr { my ( $class, $localaddr, $remoteaddr, $timeout ) = @_; my $self = {}; print STDDBG "Net::Ident::newFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n" if $DEBUG > 1; eval { # unpack addresses and store in my ( $localip, $remoteip ); ( $self->{localport}, $localip ) = sockaddr_in($localaddr); ( $self->{remoteport}, $remoteip ) = sockaddr_in($remoteaddr); # create a local binding port. We cannot bind to INADDR_ANY, it has # to be bind (bound?) to the same IP address as the connection we're # interested in on machines with multiple IP addresses my $localbind = sockaddr_in( 0, $localip ); # store max time $self->{maxtime} = defined($timeout) ? time + $timeout : undef; # create a remote connect point my $identbind = sockaddr_in( $identport, $remoteip ); # create a new FileHandle $self->{fh} = FileHandle->new; # create a stream socket. socket( $self->{fh}, PF_INET, SOCK_STREAM, $tcpproto ) or die "= socket failed: $!\n"; # bind it to the same IP number as the local end of THESOCK bind( $self->{fh}, $localbind ) or die "= bind failed: $!\n"; # make it a non-blocking socket if ( $^O ne 'MSWin32' ) { $self->{fh}->blocking(0) or die "= set non-blocking failed: $!\n"; } # connect it to the remote identd port, this can return EINPROGRESS. # for some reason, reading $! twice doesn't work as it should connect( $self->{fh}, $identbind ) or $!{EINPROGRESS} or die "= connect failed: $!\n"; $self->{fh}->blocking(0) if $^O eq 'MSWin32'; }; if ( $@ =~ /^= (.*)/ ) { # here's the catch of the throw # return false, try to preserve errno local ($!); $self->{error} = "Net::Ident::new: $1\n"; print STDDBG $self->{error} if $DEBUG; # this deletes the FileHandle, which gets closed, # so that might change errno delete $self->{fh}; # do NOT return, so the constructor always succeeds } elsif ($@) { # something else went wrong. barf up completely. confess($@); } # clear errno in case it contains EINPROGRESS $! = 0; # mark the state of the connection, consistent with new() $self->{state} = $self->{error} ? 'error' : 'connect'; # return a blessed reference bless $self, $class; } # send the query to the remote daemon. # object method sub query { my ($self) = @_; my ( $wmask, $timeout, $fileno, $err, $query ); print STDDBG "Net::Ident::query\n" if $DEBUG > 1; # bomb out if no fh return undef unless $self->{fh}; # "try" eval { $self->{state} eq 'connect' or die "= calling in the wrong order\n"; $fileno = fileno $self->{fh}; # calculate the time left, abort if necessary. Note that $timeout # is simply left undef if $self->{maxtime} is not defined if ( defined( $self->{maxtime} ) && ( $timeout = $self->{maxtime} - time ) < 0 ) { die "= Connection timed out\n"; } # wait until the socket becomes writable. $wmask = ''; vec( $wmask, $fileno, 1 ) = 1; scalar select( undef, $wmask, undef, $timeout ) or die "= Connection timed out\n"; # fh must be writable now vec( $wmask, $fileno, 1 ) or die "= connection timed out or error: $!\n"; # check for errors via getsockopt(SO_ERROR) $err = getsockopt( $self->{fh}, SOL_SOCKET, SO_ERROR ); if ( !defined($err) || ( $! = unpack( 'L', $err ) ) ) { die "= connect: $!\n"; } # create the query, based on the remote port and the local port $query = "$self->{remoteport},$self->{localport}\r\n"; # write the query. Ignore the chance that such a short # write will be fragmented. syswrite( $self->{fh}, $query, length $query ) == length $query or die "= fragmented write on socket: $!\n"; }; if ( $@ =~ /^= (.*)/ ) { # here's the catch of the throw # return false, try to preserve errno local ($!); $self->{error} = "Net::Ident::query: $1\n"; print STDDBG $self->{error} if $DEBUG; # this deletes the FileHandle, which gets closed, # so that might change errno delete $self->{fh}; return undef; } elsif ($@) { # something else went wrong. barf up completely. confess($@); } # initialise empty answer to prevent uninitialised value warning $self->{answer} = ''; # mark the state of the connection $self->{state} = 'query'; # return the same object on success $self; } # read data, if any, and check if it's enough. # object method sub ready { my ( $self, $blocking ) = @_; my ( $timeout, $rmask, $answer, $ret, $fileno ); print STDDBG "Net::Ident::ready blocking=" . ( $blocking ? "true\n" : "false\n" ) if $DEBUG > 1; # exit immediately if ready returned 1 before. if ( $self->{state} eq 'ready' ) { return 1; } # perform the query if not already done. if ( $self->{state} ne 'query' ) { $self->query or return undef; } # bomb out if no fh return undef unless $self->{fh}; # "try" $ret = eval { $fileno = fileno $self->{fh}; # while $blocking, but at least once... do { # calculate the time left, abort if necessary. if ( defined( $self->{maxtime} ) && ( $timeout = $self->{maxtime} - time ) < 0 ) { die "= Timeout\n"; } # zero timeout for non-blocking $timeout = 0 unless $blocking; # wait for something $rmask = ''; vec( $rmask, $fileno, 1 ) = 1; if ( select( $rmask, undef, undef, $timeout ) ) { # check for incoming data if ( vec( $rmask, $fileno, 1 ) ) { # try to read as much data as possible. $answer = ''; my $nread = sysread( $self->{fh}, $answer, 1000 ); if ( !defined $nread ) { # On Solaris, sysread on a socketpair may # return ESPIPE instead of 0 for EOF. # On Windows, close() without shutdown() sends # TCP RST, causing ECONNRESET on the peer. die "= remote end closed connection\n" if $!{ESPIPE} || $!{ECONNRESET}; die "= read returned error: $!\n"; } $nread or die "= remote end closed connection\n"; # append incoming data to total received $self->{answer} .= $answer; # check for max length length( $self->{answer} ) <= 1000 or die "= remote daemon babbling too much\n"; # if data contains a CR or LF, we are ready receiving. # strip everything after and including the CR or LF and # return success if ( $self->{answer} =~ /[\n\r]/ ) { $self->{answer} =~ s/[\n\r].*//s; print STDDBG "Net::Ident::ready received: $self->{answer}\n" if $DEBUG; # close the socket to the remote identd close( $self->{fh} ); $self->{state} = 'ready'; return 1; } } } } while $blocking; # we don't block, but we didn't receive everything yet... return false. 0; }; if ( $@ =~ /^= (.*)/ ) { # here's the catch of the throw # return undef, try to preserve errno local ($!); $self->{error} = "Net::Ident::ready: $1\n"; print STDDBG $self->{error} if $DEBUG; # this deletes the FileHandle, which gets closed, # so that might change errno delete $self->{fh}; return undef; } elsif ($@) { # something else went wrong. barf up completely. confess($@); } # return the return value from the eval{} $ret; } # return the username from the rfc931 query return. # object method sub username { my ($self) = @_; my ( $remoteport, $localport, $port1, $port2, $replytype, $reply, $opsys, $userid, $error ); print STDDBG "Net::Ident::username\n" if $DEBUG > 1; # wait for data, if necessary. return wantarray ? ( undef, undef, $self->{error} ) : undef unless $self->ready(1); # parse the received string, split it into parts. ( $port1, $port2, $replytype, $reply ) = ( $self->{answer} =~ /^\s*(\d+)\s*,\s*(\d+)\s*:\s*(ERROR|USERID)\s*:\s*(.*)$/ ); # make sure the answer parsed properly, and that the ports are the same. if ( !defined($reply) || ( $self->{remoteport} != $port1 ) || ( $self->{localport} != $port2 ) ) { $self->{error} = "Net::Ident::username couldn't parse reply or port mismatch\n"; print STDDBG $self->{error} if $DEBUG; return wantarray ? ( undef, undef, $self->{error} ) : undef; } # check for error return type if ( $replytype eq "ERROR" ) { print STDDBG "Net::Ident::username: lookup returned ERROR\n" if $DEBUG; $userid = undef; $opsys = "ERROR"; ( $error = $reply ) =~ s/\s+$//; } else { # a normal reply, parse the opsys and userid. Note that the opsys may # contain \ escaped colons, which is why the hairy regexp is necessary. unless ( ( $opsys, $userid ) = ( $reply =~ /\s*((?:[^\\:]+|\\.)*):(.*)$/ ) ) { # didn't parse properly, abort. $self->{error} = "Net::Ident::username: couldn't parse userid\n"; print STDDBG $self->{error} if $DEBUG; return wantarray ? ( undef, undef, $self->{error} ) : undef; } # remove trailing whitespace, except backwhacked whitespaces from opsys $opsys =~ s/([^\\])\s+$/$1/; # un-backwhack opsys. $opsys =~ s/\\(.)/$1/g; # in all cases is leading whitespace removed from the username, even # though rfc1413 mentions that it shouldn't be done, current # implementation practice dictates otherwise. What insane OS would # use leading whitespace in usernames anyway... $userid =~ s/^\s+//; # Test if opsys is "special": if it contains a charset definition, # or if it is "OTHER". This means that it is rfc1413-like, instead # of rfc931-like. (Why can't they make these RFCs non-conflicting??? ;) # Note that while rfc1413 (the one that superseded rfc931) indicates # that _any_ characters following the final colon are part of the # username, current implementation practice inserts a space there, # even "modern" identd daemons. # Also, rfc931 specifically mentions escaping characters, while # rfc1413 does not mention it (it isn't really necessary). Anyway, # I'm going to remove trailing whitespace from userids, and I'm # going to un-backwhack them, unless the opsys is "special". unless ( $opsys =~ /,/ || $opsys eq 'OTHER' ) { # remove trailing whitespace, except backwhacked whitespaces. $userid =~ s/([^\\])\s+$/$1/; # un-backwhack $userid =~ s/\\(.)/$1/g; } $error = undef; } # return the requested information, depending on whether in array context. if ( $DEBUG > 1 ) { print STDDBG "Net::Ident::username returns:\n"; print STDDBG "userid = ", defined $userid ? $userid : "", "\n"; print STDDBG "opsys = ", defined $opsys ? $opsys : "", "\n"; print STDDBG "error = ", defined $error ? $error : "", "\n"; } wantarray ? ( $userid, $opsys, $error ) : $userid; } # do the entire rfc931 lookup in one blow. # exportable subroutine, not a method sub lookup ($;$) { my ( $fh, $timeout ) = @_; print STDDBG "Net::Ident::lookup fh=$fh, timeout=", defined $timeout ? $timeout : "", "\n" if $DEBUG > 1; Net::Ident->new( $fh, $timeout )->username; } # do the entire rfc931 lookup from two in_addr structs sub lookupFromInAddr ($$;$) { my ( $localaddr, $remoteaddr, $timeout ) = @_; print STDDBG "Net::Ident::lookupFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n" if $DEBUG > 1; Net::Ident->newFromInAddr( $localaddr, $remoteaddr, $timeout )->username; } # alias Net::Ident::ident_lookup to Net::Ident::lookup sub ident_lookup ($;$); *ident_lookup = \&lookup; # prevent "used only once" warning ident_lookup(0) if 0; # get the FileHandle ref from the object, to be used in an external select(). # object method sub getfh ($) { my ($self) = @_; $self->{fh}; } # get the last error message. # object method sub geterror ($) { my ($self) = @_; $self->{error}; } # this is called whenever a function in @EXPORT_FAIL is imported. # simply calls the installed export hooks from %EXPORT_HOOKS, or # passes along the export_fail up the inheritance chain sub export_fail { my $pkg = shift; my $fail; my @other; foreach $fail (@_) { if ( $fail =~ /^_export_hook_(.*)$/ && $EXPORT_HOOKS{$1} ) { &{ $EXPORT_HOOKS{$1} }; } else { push @other, $fail; } } if (@other) { @other = $pkg->SUPER::export_fail(@other); } @other; } # add lookup method for FileHandle objects. Note that this relies on the # use FileHandle; sub _add_fh_method { # determine package to add method to my $pkg = grep( /^IO::/, @FileHandle::ISA ) ? "IO::Handle" : "FileHandle"; # insert method in package. Arguments are already OK for std lookup # turn off strict refs for this glob-mangling trick no strict 'refs'; *{"${pkg}::ident_lookup"} = \&lookup; print STDDBG "Added ${pkg}::ident_lookup method\n" if $DEBUG; } sub _add_apache_method { # add method to Apache::Connection class no strict 'refs'; *{"Apache::Connection::ident_lookup"} = sub { my ( $self, $timeout ) = @_; print STDDBG "Apache::Connection::ident_lookup self=$self, ", "timeout=", defined $timeout ? $timeout : "", "\n" if $DEBUG > 1; lookupFromInAddr( $self->local_addr, $self->remote_addr, $timeout ); }; print STDDBG "Added Apache::Connection::ident_lookup method\n" if $DEBUG; } 1; __END__ =for markdown [![testsuite](https://github.com/cpan-authors/Net-Ident/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/Net-Ident/actions/workflows/testsuite.yml) =head1 NAME Net::Ident - lookup the username on the remote end of a TCP/IP connection =head1 SYNOPSIS use Net::Ident; $username = Net::Ident::lookup(SOCKET, $timeout); $username = Net::Ident::lookupFromInAddr($localsockaddr, $remotesockaddr, $timeout); $obj = Net::Ident->new(SOCKET, $timeout); $obj = Net::Ident->newFromInAddr($localsockaddr, $remotesockaddr, $timeout); $status = $obj->query; $status = $obj->ready; $username = $obj->username; ($username, $opsys, $error) = $obj->username; $fh = $obj->getfh; $txt = $obj->geterror; use Net::Ident 'ident_lookup'; $username = ident_lookup(SOCKET, $timeout); use Net::Ident 'lookupFromInAddr'; $username = lookupFromInAddr($localsockaddr, $remotesockaddr, $timeout); use Net::Ident ':fh'; $username = SOCKET->ident_lookup($timeout); use Net::Ident ':apache'; # my Apache $r; $c = $r->connection; $username = $c->ident_lookup($timeout); =head1 OVERVIEW B is a module that looks up the username on the remote side of a TCP/IP connection through the ident (auth/tap) protocol described in RFC1413 (which supersedes RFC931). Note that this requires the remote site to run a daemon (often called B) to provide the requested information, so it is not always available for all TCP/IP connections. =head1 DESCRIPTION You can either use the simple interface, which does one ident lookup at a time, or use the asynchronous interface to perform (possibly) many simultaneous lookups, or simply continue serving other things while the lookup is proceeding. =head2 Simple Interface The simple interface comes in four varieties. An object oriented method call of a FileHandle object, an object oriented method of an Apache::Connection object, and as one of two different simple subroutine calls. Other than the calling method, these routines behave exactly the same. =over 4 =item C [C<, $timeout>]C<)> B is an exportable function. However, due to the generic name of the B function, it is recommended that you instead import the alias function B. Both functions are exported through C<@EXPORT_OK>, so you'll have to explicitly ask for it if you want the function B to be callable from your program. You can pass the socket using either a string, which doesn't have to be qualified with a package name, or using the more modern FileHandle calling styles: as a glob or as a reference to a glob. The Socket has to be a connected TCP/IP socket, ie. something which is either Bed or Bed. The optional timeout parameter specifies a timeout in seconds. If you do not specify a timeout, or use a value of undef, there will be no timeout (apart from any default system timeouts like TCP connection timeouts). =item C [C<, $timeout>]C<)> B is an exportable function (via C<@EXPORT_OK>). The arguments are the local and remote address of a connection, in packed ``sockaddr'' format (the kind of thing that C returns). The optional timeout value specifies a timeout in seconds, see also the description of the timeout value in the C section above. The given localaddr B have the IP address of a local interface of the machine you're calling this on, otherwise an error will occur. You can use this function whenever you have a local and remote socket address, but no direct access to the socket itself. For example, because you are parsing the output of "netstat" and extracting socket address, or because you are writing a mod_perl script under apache (in that case, also see the Apache::Connection method below). =item C [C<$timeout>] When you import the ``magic'' tag ':fh' using C, the B module extends the B class with one extra method call, B. It assumes that the object (a FileHandle) it is operating on, is a connected TCP/IP socket, ie. something which is either Bed or Bed. The optional parameter specifies the timeout in seconds, just like the timeout parameter of the function calls above. =pod Some people do not like the way that ``proper'' object design is broken by letting one module add methods to another class. This is why, starting from version 1.20, you have to explicitly ask for this behaviour to occur. Personally, I think it's a compromise: if you want an object-oriented interface, then either you make a derived class, like a FileHandleThatCanPerformIdentLookups, and make sure all appropriate internal functions get wrappers that do the necessary re-blessing. Or, you simply extend the FileHandle class. And since Perl doesn't object to this (pun intended :), I find this an acceptable solution. But you might think otherwise. =item C [C<$timeout>] When you import the ``magic'' tag ':apache' using C, the B module extends the B class with one extra method call, B. This method takes one optional parameter: a timeout value in seconds. This is a similar convenience function as the FileHandle::ident_lookup method, to be used with mod_perl scripts under Apache. =back What these functions return depends on the context: =over 4 =item scalar context In scalar context, these functions return the remote username on success, or undef on error. "Error" is rather broad, it might mean: some network error occurred, function arguments are invalid, the remote site is not responding (in time) or is not running an ident daemon, or the remote site ident daemon says there's no user connected with that particular connection. More precisely, the functions return whatever the remote daemon specified as the ID that belongs to that particular connection. This is often the username, but it doesn't necessarily have to be. Some sites, out of privacy and/or security measures, return an opaque ID that is unique for each user, but is not identical to the username. See I for more information. =item array context In array context, these functions return: C<($username, $opsys, $error)>. The I<$username> is the remote username or ID, as returned in the scalar context, or undef on error. The I<$opsys> is the remote operating system as reported by the remote ident daemon, or undef on a network error, or B<"ERROR"> when the remote ident daemon reported an error. This could also contain the character set of the returned username. See RFC1413. The I<$error> is the error message, either the error reported by the remote ident daemon (in which case I<$opsys> is B<"ERROR">), or the internal message from the B module, which includes the system errno C<$!> whenever possible. A likely candidate is B<"Connection refused"> when the remote site isn't running an ident daemon, or B<"Connection timed out"> when the remote site isn't answering our connection request. When I<$username> has a value, I<$error> is always undef, and vice versa. =back =head2 EXAMPLE The following code is a complete example, implementing a server that waits for a connection on a port, tells you who you are and what time it is, and closes the connection again. The majority of the code will look very familiar if you just read L. Exercise this server by telnetting to it, preferably from a machine that has a suitable ident daemon installed. #!/usr/bin/perl -w use Net::Ident ':fh'; # uncomment the below line if you want lots of debugging info # $Net::Ident::DEBUG = 2; use Socket; use strict; sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } my $port = shift || 2345; my $proto = getprotobyname('tcp'); socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!"; setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "setsockopt: $!"; bind(Server, sockaddr_in($port, INADDR_ANY)) or die "bind: $!"; listen(Server,SOMAXCONN) or die "listen: $!"; logmsg "server started on port $port"; my $paddr; for ( ; $paddr = accept(Client,Server); close Client) { my($port,$iaddr) = sockaddr_in($paddr); my $name = gethostbyaddr($iaddr,AF_INET) || inet_ntoa($iaddr); logmsg "connection from $name [" . inet_ntoa($iaddr) . "] at port $port"; my $username = Client->ident_lookup(30) || "~unknown"; logmsg "User at $name:$port is $username"; print Client "Hello there, $username\@$name, it's now ", scalar localtime, "\n"; } =head2 Asynchronous Interface The asynchronous interface is meant for those who know the ins and outs of the C call (the 4-argument version of C, but I didn't need saying that, did I?). This interface is completely object oriented. The following methods are available: =over 4 =item C This constructs a new Net::Ident object, and initiates the connection to the remote ident daemon. The parameters are the same as described above for the B subroutine. This method returns immediately, the supplied I<$timeout> is only stored in the object and used in future methods. If you want to implement your own timeout, that's fine. Simply throw away the object when you don't want it anymore. The constructor will always succeed. When it detects an error, however, it returns an object that "has already failed" internally. In this case, all methods will return C except for the C method, which will return the error message. The timeout is I implemented using C. In fact you can use C completely independent of this library, they do not interfere. =item C Alternative constructor, that takes two packed sockaddr structures. Otherwise behaves identical to the C constructor above. =item C This object method queries the remote rfc931 daemon, and blocks until the connection to the ident daemon is writable, if necessary (but you are supposed to make sure it is, of course). Returns true on success (or rather it returns the I<$obj> itself), or undef on error. =item C [C<$blocking>] This object method returns whether the data received from the remote daemon is complete (true or false). Returns undef on error. Reads any data from the connection. If I<$blocking> is true, it blocks and waits until all data is received (it never returns false when blocking is true, only true or undef). If I<$blocking> is not true, it doesn't block at all (unless... see below). If you didn't call C yet, this method calls it for you, which means it I block, regardless of the value of I<$blocking>, depending on whether the connection to the ident is writable. Obviously, you are supposed to call this routine whenever you see that the connection to the ident daemon is readable, and act appropriately when this returns true. Note that once B returns true, there are no longer checks on timeout (because the networking part of the lookup is over anyway). This means that even C can return true way after the timeout has expired, provided it returned true at least once before the timeout expired. This is to be construed as a feature. =item C This object method parses the return from the remote ident daemon, and blocks until the query is complete, if necessary (it effectively calls C for you if you didn't do it yourself). Returns the parsed username on success, or undef on error. In an array context, the return values are the same as described for the B subroutine. =item C This object method returns the internal FileHandle used for the connection to the remote ident daemon. Invaluable if you want it to dance in your select() ring. Returns undef when an error has occurred. =item C This object method returns the error message in case there was an error. undef when there was no error. =back An asynchronous example implementing the above server in a multi-threaded way via select, is left as an exercise for the interested reader. =head1 DISCLAIMER I make NO WARRANTY or representation, either express or implied, with respect to this software, its quality, accuracy, merchantability, or fitness for a particular purpose. This software is provided "AS IS", and you, its user, assume the entire risk as to its quality and accuracy. =head1 AUTHOR Jan-Pieter Cornet, =head1 COPYRIGHT Copyright (c) 1995, 1997, 1999 Jan-Pieter Cornet. All rights reserved. You can distribute and use this program under the same terms as Perl itself. =head1 REVISION HISTORY =over 4 =item V1.20 August 2, 1999. Finally implemented the long-asked-for lookupFromInAddr method. Other changes: =over 1 =item * No longer imports ident_lookup into package FileHandle by default, unless you explicitly ask for it (or unless you installed it that way during compile time for compatibility reasons). =item * Allow adding an ident_lookup method to the Apache::Connection class, as a convenience for mod_perl script writers. =item * Rewritten tests, included test for the Apache::Connection method by actually launching apache and performing ident lookups from within mod_perl. =item * Moved selection of FileHandle/IO::Handle class out of the Makefile.PL. PAUSE/CPAN didn't really like modules that weren't present in the distribution, and it didn't allow you to upgrade your perl version underneath. =back =item V1.11 Jan 15th, 1997. Several bugfixes, and some slight interface changes: =over 1 =item * constructor now called C instead of C, constructor now always succeeds, if something has gone wrong in the constructor, all methods return undef (like C), except for C, which returns the error message. =item * The recommended exported function is now C instead of C =item * Fixed a bug: now chooses O_NDELAY or O_NONBLOCK from %Config, instead of hardcoding O_NDELAY (argh) =item * Adding a method to FileHandle would break in perl5.004, it should get added in IO::Handle. Added intelligence in Makefile.PL to detect that and choose the appropriate package. =item * Miscellaneous pod fixes. =item * Test script now actually tests multiple different things. =back =item V1.10 Jan 11th, 1997. Complete rewrite for perl5. Requires perl5.002 or up. =item V1.02 Jan 20th, 1995. Quite a big bugfix: "connection refused" to the ident port would kill the perl process with a SIGPIPE if the connect didn't immediately signal it (ie. almost always on remote machines). Also recognises the perl5 package separator :: now on fully qualified descriptors. This is still perl4-compatible, a perl5- only version would require a rewrite to make it neater. Fixed the constants normally found in .ph files (but you shouldn't use those anyway). [this release wasn't called B, of course, it was called B] =item V1.01 Around November 1994. Removed a spurious B complaint. First public release. Has been tested against B and B. =item V1.00 Dunno, somewhere 1994. First neat collection of dusty routines put in a package. =back =head1 SEE ALSO L RFC1413, RFC931 =cut Net-Ident-1.31/META.yml000644 000765 000024 00000001550 15163570205 016227 0ustar00todd.rinaldostaff000000 000000 --- abstract: 'Lookup the username on the remote end of a TCP/IP connection' author: - 'Jan-Pieter Cornet ' build_requires: ExtUtils::MakeMaker: '0' IO::Socket: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Ident no_index: directory: - t - inc requires: Carp: '0' Errno: '0' Exporter: '0' FileHandle: '0' Socket: '0' perl: '5.010' resources: bugtracker: https://github.com/cpan-authors/Net-Ident/issues license: https://dev.perl.org/licenses/ repository: https://github.com/cpan-authors/Net-Ident.git version: '1.31' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Net-Ident-1.31/Makefile.PL000644 000765 000024 00000002365 15161476323 016741 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Makefile for Net::Ident use 5.010; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Net::Ident', ABSTRACT => 'Lookup the username on the remote end of a TCP/IP connection', AUTHOR => 'Jan-Pieter Cornet ', VERSION_FROM => 'Ident.pm', LICENSE => 'perl_5', MIN_PERL_VERSION => '5.010', PREREQ_PM => { Socket => '0', FileHandle => '0', Carp => '0', Errno => '0', Exporter => '0', }, TEST_REQUIRES => { 'Test::More' => 0, 'IO::Socket' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => "Net-Ident-*" }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { license => ['https://dev.perl.org/licenses/'], bugtracker => { web => 'https://github.com/cpan-authors/Net-Ident/issues', }, repository => { type => 'git', url => 'https://github.com/cpan-authors/Net-Ident.git', web => 'https://github.com/cpan-authors/Net-Ident', }, }, }, ); Net-Ident-1.31/.perltidyrc000644 000765 000024 00000000245 15156703743 017147 0ustar00todd.rinaldostaff000000 000000 -l=400 -i=4 -dt=4 -it=4 -bar -nsfs -nolq --break-at-old-comma-breakpoints --format-skipping --format-skipping-begin='#\s*tidyoff' --format-skipping-end='#\s*tidyon' Net-Ident-1.31/META.json000644 000765 000024 00000003107 15163570205 016377 0ustar00todd.rinaldostaff000000 000000 { "abstract" : "Lookup the username on the remote end of a TCP/IP connection", "author" : [ "Jan-Pieter Cornet " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-Ident", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Errno" : "0", "Exporter" : "0", "FileHandle" : "0", "Socket" : "0", "perl" : "5.010" } }, "test" : { "requires" : { "IO::Socket" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/cpan-authors/Net-Ident/issues" }, "license" : [ "https://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/cpan-authors/Net-Ident.git", "web" : "https://github.com/cpan-authors/Net-Ident" } }, "version" : "1.31", "x_serialization_backend" : "JSON::PP version 4.16" } Net-Ident-1.31/t/export.t000644 000765 000024 00000016253 15160057031 016727 0ustar00todd.rinaldostaff000000 000000 # Tests for Net::Ident export hooks: the :fh, :apache, and :debug tags, # and the export_fail dispatch mechanism that drives them. # # These test the rarely-exercised Exporter extension that makes # "use Net::Ident ':fh'" add methods to other packages. use 5.010; use strict; use warnings; use Test::More; # We need to test import effects in isolated ways, so we load the module # first without any tags, then test the mechanics directly. use Net::Ident; # === %EXPORT_HOOKS and @EXPORT_FAIL setup === subtest 'EXPORT_HOOKS registered correctly' => sub { ok(exists $Net::Ident::EXPORT_HOOKS{fh}, 'fh hook registered'); ok(exists $Net::Ident::EXPORT_HOOKS{apache}, 'apache hook registered'); ok(exists $Net::Ident::EXPORT_HOOKS{debug}, 'debug hook registered'); is(ref $Net::Ident::EXPORT_HOOKS{fh}, 'CODE', 'fh hook is a coderef'); is(ref $Net::Ident::EXPORT_HOOKS{apache}, 'CODE', 'apache hook is a coderef'); is(ref $Net::Ident::EXPORT_HOOKS{debug}, 'CODE', 'debug hook is a coderef'); }; subtest 'EXPORT_FAIL contains hook pseudo-functions' => sub { my %fail = map { $_ => 1 } @Net::Ident::EXPORT_FAIL; ok($fail{_export_hook_fh}, '_export_hook_fh in EXPORT_FAIL'); ok($fail{_export_hook_apache}, '_export_hook_apache in EXPORT_FAIL'); ok($fail{_export_hook_debug}, '_export_hook_debug in EXPORT_FAIL'); }; subtest 'EXPORT_TAGS contain hook pseudo-functions' => sub { is_deeply($Net::Ident::EXPORT_TAGS{fh}, ['_export_hook_fh'], ':fh tag'); is_deeply($Net::Ident::EXPORT_TAGS{apache}, ['_export_hook_apache'], ':apache tag'); is_deeply($Net::Ident::EXPORT_TAGS{debug}, ['_export_hook_debug'], ':debug tag'); }; subtest 'EXPORT_OK contains hook pseudo-functions and real exports' => sub { my %ok = map { $_ => 1 } @Net::Ident::EXPORT_OK; ok($ok{_export_hook_fh}, '_export_hook_fh in EXPORT_OK'); ok($ok{_export_hook_apache}, '_export_hook_apache in EXPORT_OK'); ok($ok{_export_hook_debug}, '_export_hook_debug in EXPORT_OK'); ok($ok{ident_lookup}, 'ident_lookup in EXPORT_OK'); ok($ok{lookup}, 'lookup in EXPORT_OK'); ok($ok{lookupFromInAddr}, 'lookupFromInAddr in EXPORT_OK'); }; # === export_fail dispatch === subtest 'export_fail dispatches known hooks' => sub { # Save and restore DEBUG to avoid side effects my $orig_debug = $Net::Ident::DEBUG; # Calling export_fail with a known hook pseudo-function should # invoke the hook and return an empty list (success) my @remaining = Net::Ident->export_fail('_export_hook_debug'); is(scalar @remaining, 0, 'known hook consumed by export_fail'); is($Net::Ident::DEBUG, $orig_debug + 1, 'debug hook incremented $DEBUG'); $Net::Ident::DEBUG = $orig_debug; }; subtest 'export_fail passes unknown symbols upstream' => sub { # Unknown symbols should be passed to SUPER::export_fail. # Exporter::export_fail returns them as-is (still failed). my @remaining = Net::Ident->export_fail('_no_such_export_xyz'); is_deeply(\@remaining, ['_no_such_export_xyz'], 'unknown symbol passes through to SUPER'); }; subtest 'export_fail handles mix of known and unknown' => sub { my $orig_debug = $Net::Ident::DEBUG; my @remaining = Net::Ident->export_fail( '_export_hook_debug', '_no_such_export_abc', ); is(scalar @remaining, 1, 'one symbol remains after dispatch'); is($remaining[0], '_no_such_export_abc', 'unknown symbol returned'); is($Net::Ident::DEBUG, $orig_debug + 1, 'debug hook still fired'); $Net::Ident::DEBUG = $orig_debug; }; # === :fh tag — _add_fh_method === subtest ':fh adds ident_lookup to the right package' => sub { # Determine which package should receive the method my $expected_pkg = grep(/^IO::/, @FileHandle::ISA) ? "IO::Handle" : "FileHandle"; # Call the hook directly Net::Ident::_add_fh_method(); # Check the method exists my $method = $expected_pkg->can('ident_lookup'); ok($method, "ident_lookup method added to $expected_pkg"); is($method, \&Net::Ident::lookup, "method is a reference to Net::Ident::lookup"); }; subtest ':fh makes FileHandle objects respond to ident_lookup' => sub { # A FileHandle object should now have the ident_lookup method # (via inheritance from IO::Handle or directly) ok(FileHandle->can('ident_lookup'), 'FileHandle->can("ident_lookup") after :fh hook'); }; # === :apache tag — _add_apache_method === subtest ':apache adds ident_lookup to Apache::Connection' => sub { # Call the hook directly Net::Ident::_add_apache_method(); # Check the method exists ok(Apache::Connection->can('ident_lookup'), 'Apache::Connection has ident_lookup method'); # Verify it's a coderef (the apache method is a closure, not # a direct alias to lookup) my $method = Apache::Connection->can('ident_lookup'); is(ref $method, 'CODE', 'method is a coderef'); }; # === :debug tag — _set_debug === subtest ':debug increments DEBUG level' => sub { my $orig = $Net::Ident::DEBUG; # Redirect STDDBG to avoid noise my $output = ''; { local *Net::Ident::STDDBG; open(Net::Ident::STDDBG, '>', \$output) or die "open: $!"; Net::Ident::_set_debug(); } is($Net::Ident::DEBUG, $orig + 1, 'DEBUG incremented by 1'); like($output, qr/Debugging turned to level/, 'debug message printed'); $Net::Ident::DEBUG = $orig; }; subtest ':debug stacks — multiple calls increase level' => sub { my $orig = $Net::Ident::DEBUG; { local *Net::Ident::STDDBG; open(Net::Ident::STDDBG, '>', \my $devnull) or die "open: $!"; Net::Ident::_set_debug(); Net::Ident::_set_debug(); Net::Ident::_set_debug(); } is($Net::Ident::DEBUG, $orig + 3, 'three calls increment DEBUG by 3'); $Net::Ident::DEBUG = $orig; }; # === Full import simulation === subtest 'use Net::Ident with :fh tag via import' => sub { # Simulate what "use Net::Ident ':fh'" does # The import mechanism goes through Exporter, which calls export_fail # for symbols in @EXPORT_FAIL. We test the whole chain here. # Create a fresh test package to verify the import doesn't pollute { package TestImportFH; Net::Ident->import(':fh'); } # The :fh tag should have caused _add_fh_method to run ok(FileHandle->can('ident_lookup'), 'FileHandle has ident_lookup after import(:fh)'); }; subtest 'ident_lookup can be imported as a function' => sub { { package TestImportFunc; Net::Ident->import('ident_lookup'); } ok(TestImportFunc->can('ident_lookup'), 'ident_lookup imported as function into test package'); }; subtest 'lookup can be imported as a function' => sub { { package TestImportLookup; Net::Ident->import('lookup'); } ok(TestImportLookup->can('lookup'), 'lookup imported as function into test package'); }; subtest 'lookupFromInAddr can be imported as a function' => sub { { package TestImportLFIA; Net::Ident->import('lookupFromInAddr'); } ok(TestImportLFIA->can('lookupFromInAddr'), 'lookupFromInAddr imported as function into test package'); }; done_testing; Net-Ident-1.31/t/query.t000644 000765 000024 00000021337 15160057031 016552 0ustar00todd.rinaldostaff000000 000000 # Unit tests for Net::Ident query() method. # Tests the ident protocol query phase using socketpair, # without needing a running identd or network access. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; use Socket qw(PF_UNIX SOCK_STREAM); # socketpair gives us a bidirectional pipe — one end acts as the # "identd connection", the other we hand to Net::Ident as its fh. sub make_socketpair { my ( $client, $server ); socketpair( $client, $server, PF_UNIX, SOCK_STREAM, 0 ) or plan skip_all => "socketpair not available: $!"; $client->autoflush(1); $server->autoflush(1); return ( $client, $server ); } # Read from a socket, waiting for data to arrive first. # On Windows, socketpair is emulated via TCP so data may not be # immediately available for a non-blocking read after the other end # writes. A brief select() ensures we wait for it. sub read_from_peer { my ($fh) = @_; my $rmask = ''; vec( $rmask, fileno($fh), 1 ) = 1; select( $rmask, undef, undef, 2 ); my $buf = ''; $fh->blocking(0); sysread( $fh, $buf, 1000 ); return $buf; } # Build a Net::Ident object in 'connect' state with a real filehandle. sub make_connected { my (%args) = @_; my ( $client, $server ) = make_socketpair(); my $obj = bless { state => 'connect', fh => $client, remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, maxtime => defined $args{timeout} ? time + $args{timeout} : undef, }, 'Net::Ident'; return ( $obj, $server ); } # --- query() sends correct protocol string --- subtest 'query sends correct ident protocol string' => sub { my ( $obj, $server ) = make_connected( remoteport => 6191, localport => 23, ); my $result = $obj->query; ok( $result, 'query() returns true on success' ); is( ref $result, 'Net::Ident', 'query() returns the object itself' ); # Read what was sent to the server end my $sent = read_from_peer($server); is( $sent, "6191,23\r\n", 'correct ident query sent (remoteport,localport\\r\\n)' ); close $server; }; subtest 'query transitions state to query' => sub { my ( $obj, $server ) = make_connected(); is( $obj->{state}, 'connect', 'state starts as connect' ); $obj->query; is( $obj->{state}, 'query', 'state transitions to query after query()' ); close $server; }; subtest 'query initialises empty answer buffer' => sub { my ( $obj, $server ) = make_connected(); $obj->query; is( $obj->{answer}, '', 'answer buffer initialised to empty string' ); close $server; }; # --- query() with different port values --- subtest 'query with high port numbers' => sub { my ( $obj, $server ) = make_connected( remoteport => 65535, localport => 49152, ); $obj->query; my $sent = read_from_peer($server); is( $sent, "65535,49152\r\n", 'high port numbers formatted correctly' ); close $server; }; subtest 'query with port 1' => sub { my ( $obj, $server ) = make_connected( remoteport => 1, localport => 1, ); $obj->query; my $sent = read_from_peer($server); is( $sent, "1,1\r\n", 'low port numbers formatted correctly' ); close $server; }; # --- query() error conditions --- subtest 'query returns undef when no fh' => sub { my $obj = bless { state => 'connect', remoteport => 6191, localport => 23, }, 'Net::Ident'; is( $obj->query, undef, 'query returns undef when fh is missing' ); }; subtest 'query returns undef when called in wrong state' => sub { my ( $obj, $server ) = make_connected(); # Set state to something other than 'connect' $obj->{state} = 'ready'; my $result = $obj->query; is( $result, undef, 'query returns undef when state is not connect' ); like( $obj->geterror, qr/wrong order/i, 'error mentions wrong order' ); close $server; }; subtest 'query on error-state object returns undef' => sub { my $obj = bless { state => 'error', error => "Net::Ident::new: fh undef\n", }, 'Net::Ident'; is( $obj->query, undef, 'query returns undef for error-state object' ); }; # --- Full end-to-end: query → ready → username --- subtest 'end-to-end: query then ready then username' => sub { my ( $obj, $server ) = make_connected( remoteport => 6191, localport => 23, timeout => 5, ); # Phase 1: query ok( $obj->query, 'query succeeds' ); is( $obj->{state}, 'query', 'state is query' ); # Phase 2: server reads the query and sends a response my $query_str = read_from_peer($server); is( $query_str, "6191,23\r\n", 'server received correct query' ); # Server sends ident response. Use shutdown() to send FIN before # close — on Windows, close() alone can send RST which destroys # buffered data before the client reads it. print $server "6191, 23 : USERID : UNIX : testuser\r\n"; shutdown( $server, 1 ); close $server; # Phase 3: ready my $ready = $obj->ready(1); is( $ready, 1, 'ready returns 1 after response received' ); is( $obj->{state}, 'ready', 'state is ready' ); # Phase 4: username my ( $user, $opsys, $error ) = $obj->username; is( $user, 'testuser', 'username parsed correctly' ); is( $opsys, 'UNIX', 'opsys parsed correctly' ); is( $error, undef, 'no error' ); }; subtest 'end-to-end: query then ERROR response' => sub { my ( $obj, $server ) = make_connected( remoteport => 6191, localport => 23, timeout => 5, ); $obj->query; # Drain query, send ERROR response read_from_peer($server); print $server "6191, 23 : ERROR : NO-USER\r\n"; shutdown( $server, 1 ); close $server; my ( $user, $opsys, $error ) = $obj->username; is( $user, undef, 'username undef on ERROR' ); is( $opsys, 'ERROR', 'opsys is ERROR' ); is( $error, 'NO-USER', 'error is NO-USER' ); }; subtest 'end-to-end: ERROR response with abrupt close' => sub { # On Windows, close() without shutdown() sends TCP RST (ECONNRESET). # Verify ready() treats ECONNRESET as a clean disconnect rather than # a fatal error, so the response that was already received is usable. my ( $obj, $server ) = make_connected( remoteport => 6191, localport => 23, timeout => 5, ); $obj->query; # Drain query, send ERROR response, close WITHOUT shutdown read_from_peer($server); print $server "6191, 23 : ERROR : NO-USER\r\n"; close $server; my ( $user, $opsys, $error ) = $obj->username; # On Unix the response arrives before EOF; on Windows the RST may # race with the data. Accept either a successful parse or a # graceful "remote end closed connection" error. if ( defined $opsys ) { is( $user, undef, 'username undef on ERROR (abrupt close)' ); is( $opsys, 'ERROR', 'opsys is ERROR (abrupt close)' ); is( $error, 'NO-USER', 'error is NO-USER (abrupt close)' ); } else { # ECONNRESET arrived before data — ready() should still not die like( $obj->geterror // '', qr/remote end closed connection|read returned error/, 'abrupt close handled gracefully' ); pass('abrupt close: opsys not available (acceptable on Windows)'); pass('abrupt close: error not available (acceptable on Windows)'); } }; subtest 'end-to-end: auto-query from ready' => sub { # ready() should call query() automatically if state is 'connect' my ( $obj, $server ) = make_connected( remoteport => 6191, localport => 23, timeout => 5, ); is( $obj->{state}, 'connect', 'starts in connect state' ); # Write response to server end before calling ready — # use a fork so the response arrives after query sends its request my $pid = fork(); if ( !defined $pid ) { plan skip_all => "fork not available: $!"; } if ( $pid == 0 ) { # child: wait briefly, read query, send response close $obj->{fh}; # close client end in child my $q = ''; $server->blocking(1); sysread( $server, $q, 1000 ); print $server "6191, 23 : USERID : UNIX : autouser\r\n"; shutdown( $server, 1 ); close $server; exit 0; } # parent — do NOT close $server before ready(). On Solaris, # closing one end of a PF_UNIX socketpair can invalidate the # other end even across fork. my $ready = $obj->ready(1); is( $ready, 1, 'ready auto-queries and succeeds' ); my $user = scalar $obj->username; is( $user, 'autouser', 'username from auto-queried flow' ); waitpid( $pid, 0 ); close $server; }; done_testing; Net-Ident-1.31/t/0use.t000644 000765 000024 00000000151 15160057031 016250 0ustar00todd.rinaldostaff000000 000000 use 5.010; use strict; use warnings; use Test::More tests => 1; use_ok('Net::Ident', ':fh', ':apache'); Net-Ident-1.31/t/parse.t000644 000765 000024 00000024115 15157345700 016525 0ustar00todd.rinaldostaff000000 000000 # Unit tests for Net::Ident response parsing (username method). # These tests exercise the RFC1413/931 protocol parser without # needing a running identd or any network access. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; # Subclass that overrides ready() so we can test parsing in isolation. # In real use, ready() handles network I/O and sets state to 'ready'. # Here we skip that and go straight to the parser. { package Net::Ident::MockReady; our @ISA = ('Net::Ident'); sub ready { 1 } } # Helper: create a Net::Ident object with a pre-set answer, # bypassing all network code. sub make_ident { my (%args) = @_; my $obj = bless { remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, answer => $args{answer}, state => 'ready', }, 'Net::Ident::MockReady'; return $obj; } # --- Successful USERID responses --- subtest 'basic USERID response' => sub { my $obj = make_ident( answer => '6191, 23 : USERID : UNIX : joe', remoteport => 6191, localport => 23, ); my ($user, $opsys, $error) = $obj->username; is($user, 'joe', 'username parsed correctly'); is($opsys, 'UNIX', 'opsys parsed correctly'); is($error, undef, 'no error on success'); # scalar context is(scalar $obj->username, 'joe', 'scalar context returns username'); }; subtest 'username with spaces' => sub { my $obj = make_ident(answer => '6191, 23 : USERID : UNIX : joe smith '); my ($user, $opsys, $error) = $obj->username; is($user, 'joe smith', 'leading space stripped, trailing space stripped'); is($opsys, 'UNIX', 'opsys correct'); is($error, undef, 'no error'); }; subtest 'backslash-escaped characters in userid (rfc931 style)' => sub { my $obj = make_ident(answer => '6191, 23 : USERID : UNIX : joe\\:user'); my ($user, $opsys, $error) = $obj->username; is($user, 'joe:user', 'backslash-escaped colon unescaped'); }; subtest 'backslash-escaped characters in opsys' => sub { my $obj = make_ident(answer => '6191, 23 : USERID : UNIX\\:BSD : joe'); my ($user, $opsys, $error) = $obj->username; is($opsys, 'UNIX:BSD', 'backslash-escaped colon in opsys unescaped'); }; subtest 'OTHER opsys preserves userid verbatim' => sub { # rfc1413: OTHER means the userid is an opaque token, no unescaping my $obj = make_ident(answer => '6191, 23 : USERID : OTHER : abc\\:def '); my ($user, $opsys, $error) = $obj->username; is($user, 'abc\\:def ', 'OTHER: no unescaping, trailing space preserved'); is($opsys, 'OTHER', 'opsys is OTHER'); }; subtest 'charset in opsys (comma-separated) preserves userid' => sub { # rfc1413: opsys with charset like "UNIX,US-ASCII" my $obj = make_ident(answer => '6191, 23 : USERID : UNIX,US-ASCII : joe\\:x '); my ($user, $opsys, $error) = $obj->username; is($user, 'joe\\:x ', 'charset opsys: no unescaping, trailing space preserved'); is($opsys, 'UNIX,US-ASCII', 'opsys with charset'); }; subtest 'whitespace around ports and fields' => sub { my $obj = make_ident(answer => ' 6191 , 23 : USERID : UNIX : alice'); my ($user, $opsys, $error) = $obj->username; is($user, 'alice', 'extra whitespace around ports handled'); is($opsys, 'UNIX', 'opsys correct'); }; # --- ERROR responses --- subtest 'ERROR response - INVALID-PORT' => sub { my $obj = make_ident(answer => '6191, 23 : ERROR : INVALID-PORT'); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on ERROR'); is($opsys, 'ERROR', 'opsys is ERROR'); is($error, 'INVALID-PORT', 'error message extracted'); # scalar context is(scalar $obj->username, undef, 'scalar context returns undef on error'); }; subtest 'ERROR response - NO-USER' => sub { my $obj = make_ident(answer => '6191, 23 : ERROR : NO-USER'); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef'); is($opsys, 'ERROR', 'opsys ERROR'); is($error, 'NO-USER', 'error NO-USER'); }; subtest 'ERROR response - HIDDEN-USER' => sub { my $obj = make_ident(answer => '6191, 23 : ERROR : HIDDEN-USER'); my ($user, $opsys, $error) = $obj->username; is($error, 'HIDDEN-USER', 'error HIDDEN-USER'); }; subtest 'ERROR response - UNKNOWN-ERROR' => sub { my $obj = make_ident(answer => '6191, 23 : ERROR : UNKNOWN-ERROR'); my ($user, $opsys, $error) = $obj->username; is($error, 'UNKNOWN-ERROR', 'error UNKNOWN-ERROR'); }; # --- Port mismatch --- subtest 'port mismatch - remote port' => sub { my $obj = make_ident( answer => '9999, 23 : USERID : UNIX : joe', remoteport => 6191, localport => 23, ); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on port mismatch'); like($error, qr/couldn't parse|port mismatch/i, 'error mentions parse/mismatch'); }; subtest 'port mismatch - local port' => sub { my $obj = make_ident( answer => '6191, 80 : USERID : UNIX : joe', remoteport => 6191, localport => 23, ); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on local port mismatch'); }; # --- Malformed responses --- subtest 'completely garbled response' => sub { my $obj = make_ident(answer => 'this is not a valid response'); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on garbled input'); like($error, qr/couldn't parse/i, 'error mentions parse failure'); }; subtest 'empty response' => sub { my $obj = make_ident(answer => ''); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on empty response'); }; subtest 'missing userid field' => sub { my $obj = make_ident(answer => '6191, 23 : USERID : UNIX :'); my ($user, $opsys, $error) = $obj->username; # The regex requires at least something after the last colon for opsys parsing # An empty userid after opsys should still parse ok(defined($user) || defined($error), 'handles missing userid without crash'); }; # --- Object in error state (no network connection made) --- subtest 'object in error state' => sub { # Use real Net::Ident (not MockReady) to test the actual error path: # ready() will call query() which returns undef because there's no fh, # and username() returns the error. my $obj = bless { state => 'error', error => "Net::Ident::new: fh undef\n", }, 'Net::Ident'; my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef for error-state object'); is($opsys, undef, 'opsys undef for error-state object'); like($error, qr/fh undef/, 'error message preserved'); }; # --- geterror method --- subtest 'geterror returns stored error' => sub { my $obj = bless { state => 'error', error => "some error\n", }, 'Net::Ident'; like($obj->geterror, qr/some error/, 'geterror returns the error'); }; subtest 'geterror returns undef when no error' => sub { my $obj = make_ident(answer => '6191, 23 : USERID : UNIX : joe'); is($obj->geterror, undef, 'no error stored initially'); }; # --- getfh method --- subtest 'getfh returns undef for error-state object' => sub { my $obj = bless { state => 'error', error => "Net::Ident::new: fh undef\n", }, 'Net::Ident'; is($obj->getfh, undef, 'getfh undef when no fh'); }; # --- newFromInAddr error state consistency --- subtest 'newFromInAddr sets error state on failure' => sub { # Use an IP not bound to any local interface — bind() will fail # with "Cannot assign requested address" my $bad_local = Socket::sockaddr_in(12345, Socket::inet_aton("192.0.2.1")); my $bad_remote = Socket::sockaddr_in(113, Socket::inet_aton("192.0.2.2")); my $obj = Net::Ident->newFromInAddr($bad_local, $bad_remote); # Constructor should succeed (returns blessed object) isa_ok($obj, 'Net::Ident', 'constructor succeeds even on error'); # But state should be 'error', not 'connect' is($obj->{state}, 'error', 'state is error after bind failure'); # Error message should be set like($obj->geterror, qr/bind failed/i, 'error message mentions bind'); # getfh should return undef (fh was deleted) is($obj->getfh, undef, 'no filehandle after error'); }; # --- ready() method --- subtest 'ready returns 1 on repeated calls after success' => sub { # This tests the fix for the dead-code bug where the elsif(state eq 'ready') # was unreachable, causing subsequent ready() calls to fail instead of # returning 1 as documented. my $obj = make_ident(answer => '6191, 23 : USERID : UNIX : joe'); # State is already 'ready', so ready() should return 1 immediately is($obj->ready(0), 1, 'first ready() call returns 1'); is($obj->ready(0), 1, 'second ready() call still returns 1'); is($obj->ready(1), 1, 'ready(blocking) also returns 1'); }; # --- ready() EOF handling --- subtest 'ready returns undef when remote closes without newline' => sub { # Regression test: sysread returning 0 (EOF) used to cause an infinite # loop in blocking mode because defined(0) is true. # We use socketpair to get a real filehandle that we can close one end of. use Socket qw(PF_UNIX SOCK_STREAM); my ($reader, $writer); socketpair($reader, $writer, PF_UNIX, SOCK_STREAM, 0) or plan skip_all => "socketpair not available: $!"; # Send partial data (no \r\n), then close the writer to trigger EOF print $writer "6191, 23 : USERID : UNIX : joe"; close $writer; # Build an object in 'query' state with the reader as its fh my $obj = bless { state => 'query', answer => '', fh => $reader, remoteport => 6191, localport => 23, maxtime => time + 5, # safety timeout }, 'Net::Ident'; # ready(1) should detect EOF and return undef, not loop forever my $result = $obj->ready(1); is($result, undef, 'ready returns undef on EOF without newline'); like($obj->geterror, qr/closed connection/i, 'error mentions closed connection'); close $reader; }; done_testing; Net-Ident-1.31/t/constructor.t000644 000765 000024 00000013746 15160617447 020014 0ustar00todd.rinaldostaff000000 000000 # -*- Perl -*- # Tests for Net::Ident constructor (new, newFromInAddr) and _passfh # filehandle resolution. These run without a network identd by # exercising error paths and verifying object state. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; use Socket; use IO::Socket::INET; # --- new() with various filehandle passing styles --- # new() always returns an object (never dies), but sets error state # when the handle isn't a connected socket. # 1. glob reference (the modern style) { my $obj = Net::Ident->new( \*STDERR, 5 ); ok( $obj, 'new(\\*STDERR): returns object' ); ok( $obj->geterror, 'new(\\*STDERR): has error' ); is( $obj->getfh, undef, 'new(\\*STDERR): no fh on error' ); } # 2. undef filehandle { my $obj = Net::Ident->new( undef, 5 ); ok( $obj, 'new(undef): returns object' ); like( $obj->geterror, qr/fh undef/i, 'new(undef): error mentions undef fh' ); is( $obj->getfh, undef, 'new(undef): no fh on error' ); } # 3. FileHandle object (not a socket) { require FileHandle; my $fh = FileHandle->new; open( $fh, '<', $0 ) or die "cannot open $0: $!"; my $obj = Net::Ident->new( $fh, 5 ); ok( $obj, 'new(FileHandle): returns object' ); ok( $obj->geterror, 'new(FileHandle): has error (not a socket)' ); close($fh); } # 4. Bare glob (string form) — exercises _passfh caller resolution { # Create a real filehandle in the current package open( my $orig, '<', $0 ) or die "cannot open $0: $!"; no strict 'refs'; *{"main::TESTFH"} = $orig; use strict 'refs'; my $obj = Net::Ident->new( 'TESTFH', 5 ); ok( $obj, 'new("TESTFH"): returns object for bare string' ); ok( $obj->geterror, 'new("TESTFH"): error (not a socket)' ); # Key: _passfh resolved the unqualified name without crashing like( $obj->geterror, qr/getsockname|getpeername/i, 'new("TESTFH"): error is from socket ops, not name resolution' ); close($orig); } # 5. Fully qualified glob string — _passfh skips caller resolution { open( my $orig, '<', $0 ) or die "cannot open $0: $!"; no strict 'refs'; *{"main::TESTFH2"} = $orig; use strict 'refs'; my $obj = Net::Ident->new( 'main::TESTFH2', 5 ); ok( $obj, 'new("main::TESTFH2"): returns object for qualified name' ); ok( $obj->geterror, 'new("main::TESTFH2"): error (not a socket)' ); close($orig); } # --- Error-state object: all methods return undef except geterror --- { my $obj = Net::Ident->new( undef, 5 ); is( $obj->getfh, undef, 'error object: getfh returns undef' ); is( $obj->query, undef, 'error object: query returns undef' ); is( $obj->ready, undef, 'error object: ready returns undef' ); my ( $user, $opsys, $error ) = $obj->username; is( $user, undef, 'error object: username returns undef' ); ok( $error, 'error object: username error in list context' ); my $scalar_user = $obj->username; is( $scalar_user, undef, 'error object: username returns undef in scalar context' ); } # --- newFromInAddr with valid local address --- # Uses 127.0.0.1 as local and 192.0.2.1 (TEST-NET-1) as remote. # The connect to 192.0.2.1:113 will fail (bind may succeed but connect won't). { my $local = sockaddr_in( 12345, inet_aton('127.0.0.1') ); my $remote = sockaddr_in( 12345, inet_aton('192.0.2.1') ); my $obj = Net::Ident->newFromInAddr( $local, $remote, 2 ); ok( $obj, 'newFromInAddr(127.0.0.1, 192.0.2.1): returns object' ); # Either gets an error from bind/connect or creates a connection object # On most systems, bind to 127.0.0.1 succeeds but connect to TEST-NET fails if ( $obj->geterror ) { like( $obj->geterror, qr/bind|connect/i, 'newFromInAddr: error is from bind or connect' ); } else { ok( $obj->getfh, 'newFromInAddr: has fh when no immediate error' ); } } # --- new() with a real socket (not connected) --- # A socket that exists but isn't connected should fail on getsockname/getpeername { socket( my $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') || 6 ) or die "socket: $!"; my $obj = Net::Ident->new( $sock, 5 ); ok( $obj, 'new(unconnected socket): returns object' ); ok( $obj->geterror, 'new(unconnected socket): has error' ); close($sock); } # --- new() with a connected socket (loopback, no identd) --- # Creates a TCP listener, connects to it, then does an ident lookup. # Without identd, the lookup will fail at connect to port 113. SKIP: { my $listener = IO::Socket::INET->new( Listen => 1, LocalAddr => '127.0.0.1', Proto => 'tcp', ); skip 'cannot create listener socket', 4 unless $listener; my $port = $listener->sockport; my $client = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', ); skip 'cannot connect to listener', 4 unless $client; my $server = $listener->accept; skip 'accept failed', 4 unless $server; # This exercises the full new() path: _passfh, getsockname, getpeername, # newFromInAddr. The ident connect to 127.0.0.1:113 will likely fail. my $obj = Net::Ident->new( $client, 2 ); ok( $obj, 'new(connected socket): returns object' ); # The object should have extracted the correct ports if ( !$obj->geterror ) { ok( $obj->getfh, 'new(connected socket): has ident fh' ); # query + ready should eventually fail (no identd) my ( $user, $opsys, $error ) = $obj->username; ok( !defined $user, 'no identd: username is undef' ); ok( $error, "no identd: got error: " . ( $error // '' ) ); } else { # On some systems, connect to 113 fails immediately like( $obj->geterror, qr/connect|refused|timed/i, 'new(connected socket): error from ident connect' ); pass('skipping username test — ident connect failed immediately'); pass('skipping username test — ident connect failed immediately'); } close($client); close($server); close($listener); } done_testing; Net-Ident-1.31/t/async.t000644 000765 000024 00000026322 15160057031 016521 0ustar00todd.rinaldostaff000000 000000 # Tests for the Net::Ident async (non-blocking) interface: query(), ready(), # getfh(), and the state machine transitions. Uses socketpair for real I/O # without needing a running identd or network access. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; use Socket qw(PF_UNIX SOCK_STREAM); # Helper: create a socketpair and return both ends. # The "ident" end goes into the Net::Ident object's {fh}; # the "remote" end is what we write/read to simulate the remote identd. sub make_socketpair { my ($ident_end, $remote_end); socketpair($ident_end, $remote_end, PF_UNIX, SOCK_STREAM, 0) or plan skip_all => "socketpair not available: $!"; $remote_end->autoflush(1); return ($ident_end, $remote_end); } # Helper: build a Net::Ident object in 'connect' state with a socketpair fh, # bypassing the real connect-to-identd logic. sub make_connect_obj { my (%args) = @_; my ($ident_end, $remote_end) = make_socketpair(); my $obj = bless { state => 'connect', fh => $ident_end, remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, maxtime => defined $args{timeout} ? time + $args{timeout} : undef, }, 'Net::Ident'; return ($obj, $remote_end); } # Helper: build a Net::Ident object in 'query' state (query already sent). sub make_query_obj { my (%args) = @_; my ($ident_end, $remote_end) = make_socketpair(); my $obj = bless { state => 'query', answer => '', fh => $ident_end, remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, maxtime => defined $args{timeout} ? time + $args{timeout} : undef, }, 'Net::Ident'; return ($obj, $remote_end); } # === query() method === subtest 'query sends correct ident request' => sub { my ($obj, $remote) = make_connect_obj(remoteport => 6191, localport => 23); my $result = $obj->query; ok($result, 'query() returns truthy on success'); is($obj->{state}, 'query', 'state transitions to query'); # Read what query() sent from the remote end my $buf; sysread($remote, $buf, 100); is($buf, "6191,23\r\n", 'query sends "remoteport,localport\\r\\n"'); close $remote; }; subtest 'query initialises empty answer' => sub { my ($obj, $remote) = make_connect_obj(); $obj->query; is($obj->{answer}, '', 'answer initialised to empty string after query'); close $remote; }; subtest 'query returns undef when state is not connect' => sub { my ($obj, $remote) = make_connect_obj(); # Force wrong state $obj->{state} = 'ready'; my $result = $obj->query; is($result, undef, 'query returns undef when state is ready'); close $remote; }; subtest 'query returns undef when no fh' => sub { my $obj = bless { state => 'connect', remoteport => 6191, localport => 23, }, 'Net::Ident'; my $result = $obj->query; is($result, undef, 'query returns undef when fh is missing'); }; # === ready() method — non-blocking === subtest 'ready(0) returns 0 when no data available' => sub { my ($obj, $remote) = make_query_obj(); # Don't write anything to the remote end my $result = $obj->ready(0); is($result, 0, 'ready(0) returns 0 when no data yet'); is($obj->{state}, 'query', 'state remains query'); close $remote; }; subtest 'ready(0) returns 1 when complete response available' => sub { my ($obj, $remote) = make_query_obj(remoteport => 6191, localport => 23); # Write a complete ident response (with \r\n) print $remote "6191, 23 : USERID : UNIX : testuser\r\n"; # Give the kernel a moment to propagate data through the socketpair select(undef, undef, undef, 0.05); my $result = $obj->ready(0); is($result, 1, 'ready(0) returns 1 when complete response available'); is($obj->{state}, 'ready', 'state transitions to ready'); like($obj->{answer}, qr/testuser/, 'answer contains the response'); close $remote; }; subtest 'ready(0) accumulates partial data' => sub { my ($obj, $remote) = make_query_obj(); # Send partial data (no newline) print $remote "6191, 23 : USER"; select(undef, undef, undef, 0.05); my $result = $obj->ready(0); is($result, 0, 'ready(0) returns 0 on partial data'); is($obj->{answer}, '6191, 23 : USER', 'partial data accumulated'); # Now send the rest print $remote "ID : UNIX : bob\r\n"; select(undef, undef, undef, 0.05); $result = $obj->ready(0); is($result, 1, 'ready(0) returns 1 after remaining data arrives'); is($obj->{state}, 'ready', 'state is ready'); close $remote; }; subtest 'ready strips data after CR/LF' => sub { my ($obj, $remote) = make_query_obj(remoteport => 6191, localport => 23); print $remote "6191, 23 : USERID : UNIX : alice\r\ngarbage after"; select(undef, undef, undef, 0.05); $obj->ready(0); is($obj->{answer}, '6191, 23 : USERID : UNIX : alice', 'answer stripped at CR/LF boundary'); close $remote; }; # === ready() method — blocking === subtest 'ready(1) blocks until complete response' => sub { my ($obj, $remote) = make_query_obj(remoteport => 6191, localport => 23, timeout => 5); # Write response in a subprocess after a brief delay my $pid = fork(); if (!defined $pid) { plan skip_all => "fork not available: $!"; } if ($pid == 0) { # child: wait briefly then send data close $obj->{fh}; # child doesn't need the ident end select(undef, undef, undef, 0.1); print $remote "6191, 23 : USERID : UNIX : delayed\r\n"; shutdown($remote, 1); close $remote; exit 0; } # parent: ready(1) should block until child sends data. # Do NOT close $remote here — on Solaris, closing one end of a # PF_UNIX socketpair can immediately invalidate the other end, # even across fork. my $result = $obj->ready(1); waitpid($pid, 0); close $remote; is($result, 1, 'ready(1) returns 1 after blocking for data'); like($obj->{answer}, qr/delayed/, 'got the delayed response'); }; # === ready() auto-calls query() === subtest 'ready auto-calls query when state is connect' => sub { my ($obj, $remote) = make_connect_obj(remoteport => 6191, localport => 23, timeout => 5); # Write the ident response before calling ready — it will query first, # then read. We need a subprocess because query() blocks on select(). my $pid = fork(); if (!defined $pid) { plan skip_all => "fork not available: $!"; } if ($pid == 0) { close $obj->{fh}; # Read the query that ready()/query() will send my $buf; sysread($remote, $buf, 100); # Send response print $remote "6191, 23 : USERID : UNIX : auto\r\n"; shutdown($remote, 1); close $remote; exit 0; } # Don't close $remote before ready() — see Solaris note above. my $result = $obj->ready(1); waitpid($pid, 0); close $remote; is($result, 1, 'ready(1) succeeded after auto-calling query'); is($obj->{state}, 'ready', 'state is ready'); like($obj->{answer}, qr/auto/, 'response parsed correctly'); }; # === ready() returns 1 immediately when already ready === subtest 'ready returns 1 when already in ready state' => sub { my $obj = bless { state => 'ready', answer => '6191, 23 : USERID : UNIX : joe', remoteport => 6191, localport => 23, }, 'Net::Ident'; is($obj->ready(0), 1, 'ready(0) returns 1 when already ready'); is($obj->ready(1), 1, 'ready(1) returns 1 when already ready'); }; # === ready() EOF handling === subtest 'ready returns undef on EOF' => sub { my ($obj, $remote) = make_query_obj(timeout => 5); # Close remote end immediately (EOF with no data). # On Solaris, sysread may return ESPIPE instead of 0; the module # treats ESPIPE as EOF so this test passes on both platforms. close $remote; select(undef, undef, undef, 0.05); my $result = $obj->ready(1); is($result, undef, 'ready returns undef on immediate EOF'); like($obj->geterror, qr/closed connection/i, 'error mentions closed connection'); }; subtest 'ready returns undef on EOF after partial data' => sub { my ($obj, $remote) = make_query_obj(timeout => 5); # Send partial data then close print $remote "6191, 23 : USER"; close $remote; select(undef, undef, undef, 0.05); my $result = $obj->ready(1); is($result, undef, 'ready returns undef on EOF mid-response'); }; # === ready() babble protection === subtest 'ready returns undef when remote sends too much data' => sub { my ($obj, $remote) = make_query_obj(timeout => 5); # Send more than 1000 bytes without a newline print $remote "x" x 1100; close $remote; select(undef, undef, undef, 0.05); my $result = $obj->ready(1); is($result, undef, 'ready returns undef on babbling remote'); like($obj->geterror, qr/babbling/i, 'error mentions babbling'); }; # === getfh() === subtest 'getfh returns the internal filehandle' => sub { my ($obj, $remote) = make_connect_obj(); my $fh = $obj->getfh; ok(defined $fh, 'getfh returns a defined value'); ok(fileno($fh), 'returned fh has a valid fileno'); close $remote; }; subtest 'getfh returns undef after error' => sub { my ($obj, $remote) = make_query_obj(timeout => 5); close $remote; select(undef, undef, undef, 0.05); # Trigger the error $obj->ready(1); is($obj->getfh, undef, 'getfh returns undef after error (fh deleted)'); }; # === Full async workflow end-to-end === subtest 'full async workflow: query -> ready -> username' => sub { my ($obj, $remote) = make_connect_obj(remoteport => 6191, localport => 23, timeout => 5); # Step 1: query ok($obj->query, 'query succeeds'); # Verify the query was sent my $buf; sysread($remote, $buf, 100); is($buf, "6191,23\r\n", 'correct query sent'); # Step 2: send response print $remote "6191, 23 : USERID : UNIX : asyncuser\r\n"; select(undef, undef, undef, 0.05); # Step 3: ready (non-blocking) is($obj->ready(0), 1, 'ready returns 1'); # Step 4: parse username my ($user, $opsys, $error) = $obj->username; is($user, 'asyncuser', 'username parsed from async flow'); is($opsys, 'UNIX', 'opsys parsed correctly'); is($error, undef, 'no error'); close $remote; }; subtest 'full async workflow with ERROR response' => sub { my ($obj, $remote) = make_connect_obj(remoteport => 6191, localport => 23, timeout => 5); $obj->query; # Consume the query my $buf; sysread($remote, $buf, 100); # Send an ERROR response print $remote "6191, 23 : ERROR : HIDDEN-USER\r\n"; select(undef, undef, undef, 0.05); is($obj->ready(0), 1, 'ready returns 1 for ERROR response'); my ($user, $opsys, $error) = $obj->username; is($user, undef, 'username undef on ERROR'); is($opsys, 'ERROR', 'opsys is ERROR'); is($error, 'HIDDEN-USER', 'error string extracted'); close $remote; }; done_testing; Net-Ident-1.31/t/Ident.t000644 000765 000024 00000012055 15157345700 016456 0ustar00todd.rinaldostaff000000 000000 # -*- Perl -*- # Integration tests for Net::Ident — requires a running identd to do # meaningful testing. When no identd is reachable, the network-dependent # tests are gracefully skipped. # # Originally written 1999, modernised to Test::More 2026. use 5.010; use strict; use warnings; use Test::More; use Net::Ident qw(:fh ident_lookup); use FileHandle; use Socket; # Pipe-fork to prefix debug output with "# " so it disappears in # non-verbose TAP runs. Skip the fork on platforms that lack it. my $debug_ok = 0; if ( $^O ne 'MSWin32' ) { if ( open( my $debugfh, '|-' ) ) { # parent $debugfh->autoflush(1); *Net::Ident::STDDBG = *$debugfh; $Net::Ident::DEBUG = 2; $debug_ok = 1; } else { # child — prefix every line with "# " $| = 1; while () { s/^/# /; print; } exit 0; } } # Locate the hosts file listing machines to test against. my ($hostsfile) = grep { -r } qw( t/hosts hosts ../t/hosts ); my @hosts; if ( $hostsfile && open( my $fh, '<', $hostsfile ) ) { @hosts = grep { !/^#/ && /\S/ } <$fh>; chomp @hosts; close $fh; } @hosts = ('127.0.0.1') unless @hosts; # Try connecting to identd (port 113) on each host. Also try to # obtain a "connection refused" handle by connecting to the telnet # port on a host whose identd is down. $SIG{ALRM} = sub { 0 }; my $tcpproto = ( getprotobyname('tcp') )[2] || 6; my $identport = ( getservbyname( 'ident', 'tcp' ) )[2] || 113; my ( $connok, $connokhost, $connrefuse, $connrefusehost ); for my $host (@hosts) { diag "trying to resolve $host..."; my $addr = inet_aton($host) or next; my $fh = FileHandle->new; socket( $fh, PF_INET, SOCK_STREAM, $tcpproto ) or die "socket: $!"; diag "connecting to " . inet_ntoa($addr) . ":$identport"; alarm(10); if ( connect( $fh, sockaddr_in( $identport, $addr ) ) ) { alarm(0); diag "connected to identd on $host"; $connok ||= $fh; $connokhost ||= $host; } else { my $err = "$!"; alarm(0); if ( $err =~ /connection refused/i ) { diag "identd connection refused on $host, trying telnet port"; $fh = FileHandle->new; socket( $fh, PF_INET, SOCK_STREAM, $tcpproto ) or die "socket: $!"; alarm(10); if ( connect( $fh, sockaddr_in( 23, $addr ) ) ) { alarm(0); diag "connected to telnet on $host"; $connrefuse ||= $fh; $connrefusehost ||= $host; } else { alarm(0); diag "telnet connect failed: $!"; } } else { diag "connect failed: $err"; } } last if $connok && $connrefuse; } if ( !$connok && !$connrefuse ) { diag "WARNING: no identd or telnet host reachable — most tests will be skipped"; } # --- Identd-available tests --- SKIP: { skip "no identd connection available", 6 unless $connok; diag "running ident lookups via $connokhost"; # 1. FH->ident_lookup method my $username = $connok->ident_lookup(30); ok( $username, "FH->ident_lookup returned a username ($username)" ); # 2. Net::Ident::lookup function my $username2 = Net::Ident::lookup( $connok, 30 ); is( $username2, $username, 'Net::Ident::lookup matches FH method' ); # 3. ident_lookup with an unqualified filehandle { no strict 'refs'; *FH = $connok; *FH = \1; # prevent "used only once" warning } my $username3 = ident_lookup( 'FH', 30 ); is( $username3, $username, 'ident_lookup(unqualified FH) matches' ); # 4-5. Asynchronous interface: initiate, then close original socket my $lookup = Net::Ident->new( $connok, 30 ); ok( $lookup, 'Net::Ident->new succeeds' ); ok( $lookup->getfh && !$lookup->geterror, 'new object has fh and no error' ); # Close the original connection so the remote identd returns ERROR shutdown( $connok, 2 ); close($connok); sleep 1; # 6. The lookup should now fail (remote port gone) my ( $user, $opsys, $error ) = $lookup->username; diag "remote identd said: " . ( $error // '' ); ok( !defined $user && defined $opsys && $opsys eq 'ERROR', 'lookup fails with ERROR after closing original socket' ); } # --- Connection-refused tests --- SKIP: { skip "no connection-refused host available", 1 unless $connrefuse; diag "testing connection-refused via $connrefusehost"; my ( $user, $opsys, $error ) = $connrefuse->ident_lookup(30); ok( !defined $user && !defined $opsys && $error =~ /connection refused/i, "connection refused error: $error" ); } # --- Non-socket handle (always runs) --- { my $lookup = Net::Ident->new( \*STDERR, 30 ); ok( $lookup, 'new() on non-socket returns an object (never dies)' ); is( $lookup->getfh, undef, 'getfh returns undef for non-socket' ); ok( $lookup->geterror, 'geterror reports the failure: ' . ( $lookup->geterror // '' ) ); } done_testing; Net-Ident-1.31/t/compat.t000755 000765 000024 00000006733 15157345700 016707 0ustar00todd.rinaldostaff000000 000000 # Test compatibility-mode FH lookups, if enabled. # Compatibility mode auto-imports ident_lookup into FileHandle. # When not in compat mode, the test is skipped entirely. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; use Socket; use FileHandle; # Check if compatibility mode is active (ident_lookup auto-exported). if ( !grep { $_ eq '_export_hook_fh' } @Net::Ident::EXPORT ) { plan skip_all => 'not in compatibility mode'; } # Pipe-fork to prefix debug output with "# " (skip on Windows). if ( $^O ne 'MSWin32' ) { if ( open( my $debugfh, '|-' ) ) { $debugfh->autoflush(1); *Net::Ident::STDDBG = *$debugfh; $Net::Ident::DEBUG = 2; } else { $| = 1; while () { s/^/# /; print; } exit 0; } } # Locate the hosts file. my ($hostsfile) = grep { -r } qw( t/hosts hosts ../t/hosts ); my @hosts; if ( $hostsfile && open( my $fh, '<', $hostsfile ) ) { @hosts = grep { !/^#/ && /\S/ } <$fh>; chomp @hosts; close $fh; } @hosts = ('127.0.0.1') unless @hosts; # Try connecting to identd / telnet on hosts. $SIG{ALRM} = sub { 0 }; my $tcpproto = ( getprotobyname('tcp') )[2] || 6; my $identport = ( getservbyname( 'ident', 'tcp' ) )[2] || 113; my ( $connok, $connokhost, $connrefuse, $connrefusehost ); for my $host (@hosts) { diag "trying to resolve $host..."; my $addr = inet_aton($host) or next; my $fh = FileHandle->new; socket( $fh, PF_INET, SOCK_STREAM, $tcpproto ) or die "socket: $!"; diag "connecting to " . inet_ntoa($addr) . ":$identport"; alarm(10); if ( connect( $fh, sockaddr_in( $identport, $addr ) ) ) { alarm(0); diag "connected to identd on $host"; $connok ||= $fh; $connokhost ||= $host; } else { my $err = "$!"; alarm(0); if ( $err =~ /connection refused/i ) { diag "identd refused on $host, trying telnet port"; $fh = FileHandle->new; socket( $fh, PF_INET, SOCK_STREAM, $tcpproto ) or die "socket: $!"; alarm(10); if ( connect( $fh, sockaddr_in( 23, $addr ) ) ) { alarm(0); $connrefuse ||= $fh; $connrefusehost ||= $host; } else { alarm(0); } } } last if $connok && $connrefuse; } if ( !$connok && !$connrefuse ) { diag "WARNING: no identd or telnet host reachable — most tests will be skipped"; } # --- Compat-mode ident lookup (identd available) --- SKIP: { skip "no identd connection available", 1 unless $connok; diag "compat-mode FH->ident_lookup via $connokhost"; my $username = $connok->ident_lookup(30); ok( $username, "compat FH->ident_lookup returned: $username" ); } # --- Connection-refused test --- SKIP: { skip "no connection-refused host available", 1 unless $connrefuse; my ( $user, $opsys, $error ) = $connrefuse->ident_lookup(30); ok( !defined $user && !defined $opsys && $error =~ /connection refused/i, "compat connection-refused error: $error" ); } # --- Non-socket handle --- { my ( $user, $opsys, $error ) = STDERR->ident_lookup(30); ok( !defined $user && !defined $opsys && $error, 'compat ident_lookup on non-socket fails gracefully' ); diag "got: user=" . ( $user // '' ) . " opsys=" . ( $opsys // '' ) . " error=" . ( $error // '' ); } done_testing; Net-Ident-1.31/t/lookup.t000644 000765 000024 00000011200 15161535050 016705 0ustar00todd.rinaldostaff000000 000000 # Tests for the convenience lookup functions: lookupFromInAddr() # and lookup(). These are the procedural interface to Net::Ident, # wrapping the OO new/newFromInAddr → username pipeline. # # Most of these tests run without a network identd by using loopback # sockets that will fail at the identd connect stage — but they # exercise the full code path through to username() and verify # correct return values in both scalar and list context. use 5.010; use strict; use warnings; use Test::More; use Net::Ident qw(lookup lookupFromInAddr ident_lookup); use Socket; use IO::Socket::INET; # --- lookupFromInAddr: scalar context (no identd) --- subtest 'lookupFromInAddr scalar context without identd' => sub { # Build sockaddr_in structs for a loopback connection. # We bind a listener so the local address is real, then forge the # remote address. The ident connect to 127.0.0.1:113 will fail. my $local = sockaddr_in( 9999, inet_aton('127.0.0.1') ); my $remote = sockaddr_in( 8888, inet_aton('127.0.0.1') ); my $result = lookupFromInAddr( $local, $remote, 2 ); is( $result, undef, 'returns undef when no identd is running' ); }; # --- lookupFromInAddr: list context (no identd) --- subtest 'lookupFromInAddr list context without identd' => sub { my $local = sockaddr_in( 9999, inet_aton('127.0.0.1') ); my $remote = sockaddr_in( 8888, inet_aton('127.0.0.1') ); my ( $user, $opsys, $error ) = lookupFromInAddr( $local, $remote, 2 ); is( $user, undef, 'user is undef' ); ok( $error, "error is set: " . ( $error // '' ) ); }; # --- lookup: scalar context with connected socket (no identd) --- subtest 'lookup with connected socket, scalar context' => sub { my $listener = IO::Socket::INET->new( Listen => 1, LocalAddr => '127.0.0.1', Proto => 'tcp', ); plan skip_all => 'cannot create listener socket' unless $listener; my $port = $listener->sockport; my $client = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', ); plan skip_all => 'cannot connect to listener' unless $client; my $server = $listener->accept; my $result = lookup( $client, 2 ); is( $result, undef, 'lookup returns undef when no identd' ); close($client); close($server); close($listener); }; # --- lookup: list context with connected socket (no identd) --- subtest 'lookup with connected socket, list context' => sub { my $listener = IO::Socket::INET->new( Listen => 1, LocalAddr => '127.0.0.1', Proto => 'tcp', ); plan skip_all => 'cannot create listener socket' unless $listener; my $port = $listener->sockport; my $client = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', ); plan skip_all => 'cannot connect to listener' unless $client; my $server = $listener->accept; my ( $user, $opsys, $error ) = lookup( $client, 2 ); is( $user, undef, 'user is undef when no identd' ); ok( $error, "error is set: " . ( $error // '' ) ); close($client); close($server); close($listener); }; # --- ident_lookup is an alias for lookup --- subtest 'ident_lookup alias works identically to lookup' => sub { my $listener = IO::Socket::INET->new( Listen => 1, LocalAddr => '127.0.0.1', Proto => 'tcp', ); plan skip_all => 'cannot create listener socket' unless $listener; my $port = $listener->sockport; my $client = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', ); plan skip_all => 'cannot connect to listener' unless $client; my $server = $listener->accept; my $result = ident_lookup( $client, 2 ); is( $result, undef, 'ident_lookup returns undef when no identd' ); close($client); close($server); close($listener); }; # --- lookup with bad filehandle --- subtest 'lookup with non-socket filehandle' => sub { my $result = lookup( \*STDERR, 2 ); is( $result, undef, 'lookup on non-socket returns undef' ); }; # --- lookupFromInAddr with different local/remote addresses --- subtest 'lookupFromInAddr with unreachable remote' => sub { # 192.0.2.1 (TEST-NET-1) — guaranteed non-routable my $local = sockaddr_in( 12345, inet_aton('127.0.0.1') ); my $remote = sockaddr_in( 80, inet_aton('192.0.2.1') ); my ( $user, $opsys, $error ) = lookupFromInAddr( $local, $remote, 1 ); is( $user, undef, 'user is undef for unreachable remote' ); ok( $error, "error for unreachable remote: " . ( $error // '' ) ); }; done_testing; Net-Ident-1.31/t/hosts000644 000765 000024 00000001056 15156703743 016314 0ustar00todd.rinaldostaff000000 000000 # list of hosts on which we can test ident lookups # also include hosts that don't run identd, but do run a regular "telnet" # server, to test "connection refused" errors from the library. # note that these tests actually rely on a common buglet in identd # implementations, in that they let you perform an ident lookup on # a connection that is incoming. # # Right now we know of no ident servers on the internet that serve out. # Patches welcome https://github.com/cpan-authors/Net-Ident 127.0.0.1 #pc.xs4all.nl #xs4all.nl #lyrix.xs4all.nl #lysator.liu.seNet-Ident-1.31/t/timeout.t000644 000765 000024 00000014611 15161535050 017073 0ustar00todd.rinaldostaff000000 000000 # Tests for timeout behavior in query() and ready(). # Verifies that the timeout code paths fire correctly when the # remote identd is slow or unresponsive. use 5.010; use strict; use warnings; use Test::More; use Net::Ident; use Socket qw(PF_UNIX SOCK_STREAM); # Helper: create a socketpair. sub make_socketpair { my ( $client, $server ); socketpair( $client, $server, PF_UNIX, SOCK_STREAM, 0 ) or plan skip_all => "socketpair not available: $!"; $client->autoflush(1); $server->autoflush(1); return ( $client, $server ); } # Build a Net::Ident object in 'connect' state with a real filehandle. sub make_connect_obj { my (%args) = @_; my ( $client, $server ) = make_socketpair(); my $obj = bless { state => 'connect', fh => $client, remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, maxtime => $args{maxtime}, }, 'Net::Ident'; return ( $obj, $server ); } # Build a Net::Ident object in 'query' state (query already sent). sub make_query_obj { my (%args) = @_; my ( $client, $server ) = make_socketpair(); my $obj = bless { state => 'query', answer => '', fh => $client, remoteport => $args{remoteport} // 6191, localport => $args{localport} // 23, maxtime => $args{maxtime}, }, 'Net::Ident'; return ( $obj, $server ); } # === query() timeout paths === subtest 'query() times out when maxtime already expired' => sub { my ( $obj, $server ) = make_connect_obj( maxtime => time - 1 ); my $result = $obj->query; is( $result, undef, 'query() returns undef on timeout' ); like( $obj->geterror, qr/timed out/i, 'error mentions timeout' ); is( $obj->getfh, undef, 'fh cleaned up after timeout' ); close $server; }; subtest 'query() times out waiting for writable socket' => sub { # Use a very short timeout with a socket that is already writable — # socketpair sockets are immediately writable, so this tests the # pre-expiry calculation path rather than the select timeout. # We set maxtime to now+0.01 so the select returns immediately. my ( $obj, $server ) = make_connect_obj( maxtime => time + 5 ); # This should succeed since the socketpair is immediately writable my $result = $obj->query; ok( $result, 'query() succeeds with valid timeout and writable socket' ); close $server; }; # === ready() timeout paths === subtest 'ready() times out when maxtime already expired (blocking)' => sub { my ( $obj, $server ) = make_query_obj( maxtime => time - 1 ); my $result = $obj->ready(1); is( $result, undef, 'ready(1) returns undef on timeout' ); like( $obj->geterror, qr/timeout/i, 'error mentions timeout' ); is( $obj->getfh, undef, 'fh cleaned up after timeout' ); close $server; }; subtest 'ready() times out when maxtime already expired (non-blocking)' => sub { my ( $obj, $server ) = make_query_obj( maxtime => time - 1 ); my $result = $obj->ready(0); is( $result, undef, 'ready(0) returns undef on timeout' ); like( $obj->geterror, qr/timeout/i, 'error mentions timeout' ); close $server; }; subtest 'ready() select-timeout with no data (blocking, short timeout)' => sub { # Set timeout to expire very soon — the child never sends data. my ( $obj, $server ) = make_query_obj( maxtime => time + 1 ); # Don't write anything to $server, so ready() must wait then time out. # The select in ready() will wait up to (maxtime - time) seconds. # We keep the server open so it's not an EOF. # Override maxtime to something that expires very soon $obj->{maxtime} = time + 0.1; my $result = $obj->ready(1); is( $result, undef, 'ready(1) returns undef when no data arrives before timeout' ); like( $obj->geterror, qr/timeout/i, 'error mentions timeout' ); close $server; }; subtest 'ready() returns 0 (not ready) in non-blocking mode with no data' => sub { # Non-blocking ready with no timeout — should return 0, not undef my ( $obj, $server ) = make_query_obj( maxtime => undef ); my $result = $obj->ready(0); is( $result, 0, 'ready(0) returns 0 when no data available and no timeout' ); ok( !$obj->geterror, 'no error set — just not ready yet' ); close $server; }; subtest 'ready() partial data then timeout (blocking)' => sub { my ( $obj, $server ) = make_query_obj( maxtime => time + 0.2 ); # Send partial data (no \r\n terminator) syswrite( $server, "6191 , 23 : USERID" ); my $result = $obj->ready(1); is( $result, undef, 'ready(1) returns undef — partial data but no terminator before timeout' ); like( $obj->geterror, qr/timeout/i, 'error mentions timeout' ); close $server; }; # === username() timeout delegation === subtest 'username() returns undef when ready() times out' => sub { my ( $obj, $server ) = make_query_obj( maxtime => time - 1 ); my $username = $obj->username; is( $username, undef, 'username returns undef on timeout' ); # In list context, error should be present $obj->{state} = 'query'; $obj->{answer} = ''; $obj->{maxtime} = time - 1; my ( $client2, $server2 ) = make_socketpair(); $obj->{fh} = $client2; my ( $user, $opsys, $error ) = $obj->username; is( $user, undef, 'username returns undef in list context on timeout' ); ok( $error, 'error is set in list context: ' . ( $error // '' ) ); close $server; close $server2; }; # === query→ready chained timeout === subtest 'ready() calls query() which times out' => sub { # Object in 'connect' state with expired timeout. # ready() will try to call query(), which should time out. my ( $obj, $server ) = make_connect_obj( maxtime => time - 1 ); my $result = $obj->ready(1); is( $result, undef, 'ready(1) returns undef when delegated query() times out' ); like( $obj->geterror, qr/timed out/i, 'error from query timeout propagates' ); close $server; }; subtest 'no timeout when maxtime is undef (blocking ready succeeds)' => sub { my ( $obj, $server ) = make_query_obj( maxtime => undef ); # Send a complete response so ready() returns quickly syswrite( $server, "6191 , 23 : USERID : UNIX : testuser\r\n" ); my $result = $obj->ready(1); is( $result, 1, 'ready(1) succeeds with no timeout limit' ); is( $obj->{state}, 'ready', 'state is ready' ); close $server; }; done_testing;