IO-Stty-0.08/000755 000765 000024 00000000000 15163567553 014455 5ustar00todd.rinaldostaff000000 000000 IO-Stty-0.08/Changes000644 000765 000024 00000014755 15163567431 015757 0ustar00todd.rinaldostaff000000 000000 Revision history for Perl extension IO::Stty 0.08 Thu Apr 02 2026 Bug fixes: - Fix Perl 5.8 compatibility: replace // (defined-or) operator with ternary equivalent. The // operator requires Perl 5.10 but MIN_PERL_VERSION is 5.008. (GH #28, GH #29, PR #30, PR #31) - Implement crterase alias (was documented but never coded) and correct dec/crt combination documentation to match actual behavior. (PR #33) - Add exta, extb, and 134.5 baud rate aliases that were documented but silently rejected. (PR #32) - Use _POSIX_VDISABLE for disabling special characters instead of hardcoded 0, fixing 'undef'/'^-' on macOS/BSD where VDISABLE is 255. Also fix sane/cooked combos to use 'undef' for eol. (PR #37) - Handle VEOF/VMIN and VEOL/VTIME shared cc slots on Solaris/SVR4 systems where these overlap in the termios cc array. (GH #38, PR #42) - Fix _cc_to_hat() to use only _POSIX_VDISABLE, not hardcoded 0/255, preventing wrong display on Linux and macOS. (PR #46) - Add missing igncr flag to -a display output. (PR #50) - Handle getattr() failure by returning undef instead of silently continuing with zeroed flags. Return setattr() result so callers can detect failure. (PR #36) - Fix broken $private_subs reference in t/99-pod-coverage.t and remove duplicate echok in sane combo expansion. (PR #34) Improvements: - Add evenp, oddp, parity, cbreak, and litout combination aliases matching GNU stty behavior. (PR #35) - Add 'speed' query parameter to return just the output baud rate, matching GNU stty behavior. (PR #51) - Document iexten as a settable local flag in POD. (PR #36) - Document AI Policy Maintenance: - Add provides metadata to Makefile.PL for correct CPAN indexing, using MM->parse_version() for dynamic version extraction. (PR #47, PR #53) - Add strict/warnings to boilerplate test files. (PR #34) - Clarify in CLAUDE.md that README.md and MANIFEST are generated files and that release prep is human-only. (PR #53, PR #54) 0.07 Sun Mar 22 2026 Bug fixes: - Fix "Use of uninitialized value" warning in stty.pl when stdin is not a terminal. stty() returns undef when isatty fails; the script now guards with defined() before comparing. (PR #25) - Fix broken C<-icanon> POD formatting and add missing iexten to sane combination documentation. Replace "Needs documentation" stub with proper docs for show_me_the_crap(). (PR #26) Improvements: - Show min and time values in -a output. These are critical for non-canonical (raw/cbreak) mode users and match GNU stty behavior. Also adds functional tests for hat-notation control char assignment, undef/^- char disabling, and min/time setting. (PR #27) Maintenance: - Declare MIN_PERL_VERSION 5.008 in Makefile.PL to prevent CPAN from attempting installation on too-old perls. (PR #25) - Add IO::Pty as a test recommends in cpanfile for better test coverage on CPAN testers and CI. (PR #25) - Regenerate README.md from updated POD. (PR #26) 0.06 Fri Mar 20 2026 Bug fixes: - Fix show_me_the_crap() emitting "speed baud" (empty speed) when getospeed() returns a value not mapped to any standard POSIX B* constant (e.g. on OpenBSD). Now falls back to the raw numeric value. (GH #19, PR #23) - Display ispeed separately in -a output when it differs from ospeed, using the same raw-numeric fallback for unmapped values. (PR #23) - Fix ispeed test failure on Linux ptys where the kernel normalises ispeed to match ospeed during tcsetattr(). Set both speeds in a single stty() call to avoid the normalisation window. (GH #16, PR #17, PR #21) - Replace // (defined-or) operator in tests with ternary equivalent for Perl 5.8 compatibility. (GH #20, PR #24) Improvements: - Recognize --version flag in stty.pl; previously only -v and bare "version" were matched despite the POD documenting --version. (PR #15) - Modernize scripts/stty.pl: add strict/warnings, lexical variables, and a portable shebang. (PR #15) Maintenance: - Harden ispeed baud rate test against Linux pty kernel normalisation. (GH #16, PR #21) 0.05 Wed Mar 19 2026 Bug fixes: - Fix broken single-arg baud rate setting. Passing a numeric rate like "9600" as the sole argument now correctly sets both ispeed and ospeed. The single-arg code path had two independent if/else blocks instead of one if/elsif chain, so the baud rate was silently never applied. (PR #11) - Replace unsafe symbolic dereference &{"POSIX::B" . $input} in the ospeed/ispeed handlers with a static %BAUD_RATES hash lookup. The old pattern was dead code in all public releases (use strict prevented it from running) but is now properly fixed. Unknown rates produce a warning instead of dying. (PR #7, PR #11) Improvements: - Add modern baud rates B57600, B115200, and B230400 with eval guards for platforms that lack them. (PR #9) - Render control characters in hat notation (e.g. ^C, ^D) in -a output instead of raw numeric values. (PR #8) - Add special character value parsing for stty(): accept hat notation (^C), hexadecimal (0x03), octal (003), decimal, and single literal characters when setting control char values. (PR #6) Maintenance: - Add functional pty-based test suite using IO::Pty covering flag toggling, -g/-a roundtrips, raw/cooked/sane modes, baud rate setting, and control character assignment. (PR #10) - Add baud rate regression tests with a decoy-function guard against reintroduction of symbolic dereference. (PR #7) - Modernize CI: replace three separate workflow files with unified testsuite.yml using current GitHub Actions. (GH #12, PR #13) - Update stale GitHub URLs (http to https) and modernize CPAN metadata to META spec v2 with TEST_REQUIRES. (PR #14) - Add cpanfile for CI dependency management. - Re-generate README from Stty.pm. - Apply Perl::Tidy formatting. 0.04 Sat Jan 18 2020 - Switch to EU::MM - Address a few deficiencies in the way how the stty() sub processes its arguments - Enable testing on Github actions. 0.03 Thu May 6 2010 - Re-vamp IO::Stty to modern layout - stty.txt moved into POD for module - stty.pl in docs. Die if no params passed to stty 0.02_01 Tue Mar 23 2010 - Re-vamp module to Module::Build - stty.txt merged into POD so it shows up on CPAN - add Changes log - basic tests - die if no parameters passed to stty IO-Stty-0.08/MANIFEST000644 000765 000024 00000000724 15163567553 015611 0ustar00todd.rinaldostaff000000 000000 AI_POLICY.md Changes lib/IO/Stty.pm Makefile.PL MANIFEST MANIFEST.SKIP README.md scripts/stty.pl t/00-load.t t/01-baud-rate.t t/01-cc-to-hat.t t/01-functional.t t/01-parse-char-value.t t/02-combination-aliases.t t/02-show-me-the-crap.t t/02-single-arg.t t/99-pod-coverage.t t/99-pod.t t/baud-rates.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IO-Stty-0.08/AI_POLICY.md000644 000765 000024 00000013036 15163567366 016354 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.* IO-Stty-0.08/t/000755 000765 000024 00000000000 15163567552 014717 5ustar00todd.rinaldostaff000000 000000 IO-Stty-0.08/README.md000644 000765 000024 00000021346 15163563472 015736 0ustar00todd.rinaldostaff000000 000000 [![testsuite](https://github.com/cpan-authors/IO-Stty/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/IO-Stty/actions/workflows/testsuite.yml) # NAME IO::Stty - Change and print terminal line settings # SYNOPSIS # calling the script directly stty.pl [setting...] stty.pl {-a,-g,-v,--version} # Calling Stty module use IO::Stty; IO::Stty::stty(\*TTYHANDLE, @modes); use IO::Stty; $old_mode=IO::Stty::stty(\*STDIN,'-g'); # Turn off echoing. IO::Stty::stty(\*STDIN,'-echo'); # Do whatever.. grab input maybe? $read_password = <>; # Now restore the old mode. IO::Stty::stty(\*STDIN,$old_mode); # What settings do we have anyway? print IO::Stty::stty(\*STDIN,'-a'); # DESCRIPTION This is the PERL POSIX compliant stty. # INTRO This has not been tailored to the IO::File stuff but will work with it as indicated. Before you go futzing with term parameters it's a good idea to grab the current settings and restore them when you finish. stty accepts the following non-option arguments that change aspects of the terminal line operation. A \`\[-\]' before a capability means that it can be turned off by preceding it with a \`-'. # stty parameters ## Control settings - \[-\]parenb Generate parity bit in output and expect parity bit in input. - \[-\]parodd Set odd parity (even with \`-'). - cs5 cs6 cs7 cs8 Set character size to 5, 6, 7, or 8 bits. - \[-\]hupcl \[-\]hup Send a hangup signal when the last process closes the tty. - \[-\]cstopb Use two stop bits per character (one with \`-'). - \[-\]cread Allow input to be received. - \[-\]clocal Disable modem control signals. ## Input settings - \[-\]ignbrk Ignore break characters. - \[-\]brkint Breaks cause an interrupt signal. - \[-\]ignpar Ignore characters with parity errors. - \[-\]parmrk Mark parity errors (with a 255-0-character sequence). - \[-\]inpck Enable input parity checking. - \[-\]istrip Clear high (8th) bit of input characters. - \[-\]inlcr Translate newline to carriage return. - \[-\]igncr Ignore carriage return. - \[-\]icrnl Translate carriage return to newline. - \[-\]ixon Enable XON/XOFF flow control. - \[-\]ixoff Enable sending of stop character when the system input buffer is almost full, and start character when it becomes almost empty again. ## Output settings - \[-\]opost Postprocess output. ## Local settings - \[-\]isig Enable interrupt, quit, and suspend special characters. - \[-\]icanon Enable erase, kill, werase, and rprnt special characters. - \[-\]echo Echo input characters. - \[-\]echoe, \[-\]crterase Echo erase characters as backspace-space-backspace. - \[-\]echok Echo a newline after a kill character. - \[-\]echonl Echo newline even if not echoing other characters. - \[-\]noflsh Disable flushing after interrupt and quit special characters. \* Though this claims non-posixhood it is supported by the perl POSIX.pm. - \[-\]iexten Enable implementation-defined input processing. This is needed for special characters like werase and lnext to be recognized. - \[-\]tostop (np) Stop background jobs that try to write to the terminal. ## Combination settings - ek Reset the erase and kill special characters to their default values. - sane Same as: cread -ignbrk brkint -inlcr -igncr icrnl -ixoff opost isig icanon iexten echo echoe echok -echonl -noflsh -tostop also sets all special characters to their default values. - \[-\]cooked Same as: brkint ignpar istrip icrnl ixon opost isig icanon plus sets the eof and eol characters to their default values if they are the same as the min and time characters. With \`-', same as raw. - \[-\]raw Same as: -ignbrk -brkint -ignpar -parmrk -inpck -istrip -inlcr -igncr -icrnl -ixon -ixoff -opost -isig -icanon min 1 time 0 With \`-', same as cooked. - \[-\]pass8 Same as: -parenb -istrip cs8 With \`-', same as parenb istrip cs7. - crt Same as: echoe echok - dec Same as: echoe echok Also sets the interrupt special character to Ctrl-C, erase to Del, and kill to Ctrl-U. - \[-\]cbreak Same as `-icanon` (with `-`, same as `icanon`). - evenp, parity Same as: parenb -parodd cs7 - oddp Same as: parenb parodd cs7 - -evenp, -parity, -oddp Same as: -parenb cs8 - \[-\]litout Same as: -parenb -istrip -opost cs8 With `-`, same as `parenb istrip opost cs7`. ## Special characters The special characters' default values vary from system to system. They are set with the syntax \`name value', where the names are listed below and the value can be given either literally, in hat notation (\`^c'), or as an integer which may start with \`0x' to indicate hexadecimal, \`0' to indicate octal, or any other digit to indicate decimal. Giving a value of \`^-' or \`undef' disables that special character (sets it to `_POSIX_VDISABLE`, which is 0 on Linux and 255 on macOS/BSD). - intr Send an interrupt signal. - quit Send a quit signal. - erase Erase the last character typed. - kill Erase the current line. - eof Send an end of file (terminate the input). - eol End the line. - start Restart the output after stopping it. - stop Stop the output. - susp Send a terminal stop signal. ## Special settings - min N Set the minimum number of characters that will satisfy a read until the time value has expired, when `-icanon` is set. - time N Set the number of tenths of a second before reads time out if the min number of characters have not been read, when -icanon is set. - N Set the input and output speeds to N. N can be one of: 0 50 75 110 134 134.5 150 200 300 600 1200 1800 2400 4800 9600 19200 38400 57600 115200 230400 exta extb. 134.5 is the same as 134; exta is the same as 19200; extb is the same as 38400. Modern rates (57600, 115200, 230400) are only available on platforms whose POSIX implementation defines them. 0 hangs up the line if -clocal is set. ## OPTIONS - -a Print all current settings in human-readable form. - -g Print all current settings in a form that can be used as an argument to another stty command to restore the current settings. - speed Print the output baud rate. - -v,--version Print version info. # Direct Subroutines - **\_parse\_char\_value()** my $numeric = IO::Stty::_parse_char_value($value); Parse a special character value from any of the supported notations: literal integers, hat notation (`^c`), hexadecimal (`0x...`), octal (`0...`), or `undef`/`^-` to disable (returns `_POSIX_VDISABLE`). - **stty()** IO::Stty::stty(\*STDIN, @params); Returns a string for query options (`-a`, `-g`, `-v`), `undef` if the handle is not a terminal or if the terminal parameters could not be read, and a true value on success when setting parameters. From comments: I'm not feeling very inspired about this. Terminal parameters are obscure and boring. Basically what this will do is get the current setting, take the parameters, modify the setting and write it back. Zzzz. This is not especially efficent and probably not too fast. Assuming the POSIX spec has been implemented properly it should mostly work. - **show\_me\_the\_crap()** my $output = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed, \%control_chars ); Format terminal settings as a human-readable string, equivalent to `stty -a` output. Returns a multi-line string showing the current baud rate, special character assignments (in hat notation), and the state of all control, input, output, and local flags. This is the back-end for `stty(\*FH, '-a')`. # AUTHOR Austin Schutz (Initial version and maintenance) Todd Rinaldo (Maintenance) # BUGS This is use at your own risk software. Do anything you want with it except blame me for it blowing up your machine because it's full of bugs. See above for what functions are supported. It's mostly standard POSIX stuff. If any of the settings are wrong and you actually know what some of these extremely arcane settings (like what 'sane' should be in POSIX land) really should be, please open an RT ticket. # ACKNOWLEDGEMENTS None # COPYRIGHT & LICENSE Copyright 1997 Austin Schutz, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. IO-Stty-0.08/MANIFEST.SKIP000644 000765 000024 00000000151 15157006601 016331 0ustar00todd.rinaldostaff000000 000000 ^.git* ^MYMETA.* ^MANIFEST.bak ^Makefile$ ^CLAUDE.md$ ^\.perltidyrc$ ^cpanfile$ \.orig$ \.rej$ \.DS_StoreIO-Stty-0.08/META.yml000644 000765 000024 00000001546 15163567552 015733 0ustar00todd.rinaldostaff000000 000000 --- abstract: 'Change and print terminal line settings' author: - 'Austin Schutz ' build_requires: ExtUtils::MakeMaker: '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: IO-Stty no_index: directory: - t - inc provides: IO::Stty: file: lib/IO/Stty.pm version: '0.08' requires: perl: '5.008' resources: bugtracker: https://github.com/cpan-authors/IO-Stty/issues homepage: https://github.com/cpan-authors/IO-Stty license: https://dev.perl.org/licenses/ repository: https://github.com/cpan-authors/IO-Stty.git version: '0.08' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' IO-Stty-0.08/scripts/000755 000765 000024 00000000000 15163567552 016143 5ustar00todd.rinaldostaff000000 000000 IO-Stty-0.08/lib/000755 000765 000024 00000000000 15163567552 015222 5ustar00todd.rinaldostaff000000 000000 IO-Stty-0.08/Makefile.PL000644 000765 000024 00000003275 15163542132 016420 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'IO::Stty', AUTHOR => 'Austin Schutz ', VERSION_FROM => 'lib/IO/Stty.pm', ABSTRACT_FROM => 'lib/IO/Stty.pm', PL_FILES => {}, ( $ExtUtils::MakeMaker::VERSION >= 6.48 ? ( 'MIN_PERL_VERSION' => '5.008', ) : () ), ( $ExtUtils::MakeMaker::VERSION >= 6.3002 ? ( 'LICENSE' => 'perl', ) : () ), ( $ExtUtils::MakeMaker::VERSION >= 6.64 ? ( TEST_REQUIRES => { 'Test::More' => 0, }, ) : ( PREREQ_PM => { 'Test::More' => 0, }, )), dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'IO-Stty-*' }, META_MERGE => { 'meta-spec' => { version => 2 }, provides => { 'IO::Stty' => { file => 'lib/IO/Stty.pm', version => MM->parse_version('lib/IO/Stty.pm'), }, }, resources => { license => ['https://dev.perl.org/licenses/'], homepage => 'https://github.com/cpan-authors/IO-Stty', bugtracker => { web => 'https://github.com/cpan-authors/IO-Stty/issues', }, repository => { type => 'git', url => 'https://github.com/cpan-authors/IO-Stty.git', web => 'https://github.com/cpan-authors/IO-Stty', }, }, }, ); sub MY::postamble { return "readme: lib/IO/Stty.pm\n" . "\t\@perl -MPod::Markdown -e1 2>/dev/null || (echo 'Pod::Markdown is required: cpanm Pod::Markdown' >&2; exit 1)\n" . "\tpod2markdown lib/IO/Stty.pm README.md\n"; } IO-Stty-0.08/META.json000644 000765 000024 00000003053 15163567553 016077 0ustar00todd.rinaldostaff000000 000000 { "abstract" : "Change and print terminal line settings", "author" : [ "Austin Schutz " ], "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" : "IO-Stty", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "provides" : { "IO::Stty" : { "file" : "lib/IO/Stty.pm", "version" : "0.08" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/cpan-authors/IO-Stty/issues" }, "homepage" : "https://github.com/cpan-authors/IO-Stty", "license" : [ "https://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/cpan-authors/IO-Stty.git", "web" : "https://github.com/cpan-authors/IO-Stty" } }, "version" : "0.08", "x_serialization_backend" : "JSON::PP version 4.16" } IO-Stty-0.08/lib/IO/000755 000765 000024 00000000000 15163567552 015531 5ustar00todd.rinaldostaff000000 000000 IO-Stty-0.08/lib/IO/Stty.pm000644 000765 000024 00000073333 15163563465 017042 0ustar00todd.rinaldostaff000000 000000 package IO::Stty; use strict; use warnings; use POSIX; our $VERSION = '0.08'; # _POSIX_VDISABLE: the value that disables a special character slot. # On Linux this is typically 0; on macOS/BSD it is typically 255 (0xFF). # Fall back to 0 if the platform doesn't define it. my $VDISABLE; BEGIN { $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; } # Baud rate constants: standard POSIX rates plus modern rates. # Modern rates (B57600, B115200, B230400) are not available on all platforms, # so we use eval guards to include only what the current system supports. my %BAUD_RATES; my %BAUD_SPEEDS; BEGIN { my @standard = qw(0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 9600 19200 38400); my @modern = qw(57600 115200 230400); for my $rate (@standard, @modern) { my $val = eval { POSIX->can("B$rate") }; next unless $val && ref($val) eq 'CODE'; $val = eval { $val->() }; if (defined $val) { $BAUD_RATES{$rate} = $val; $BAUD_SPEEDS{$val} = $rate; } } # Standard aliases: 134.5 → B134, exta → B19200, extb → B38400 $BAUD_RATES{'134.5'} = $BAUD_RATES{'134'} if exists $BAUD_RATES{'134'}; $BAUD_RATES{'exta'} = $BAUD_RATES{'19200'} if exists $BAUD_RATES{'19200'}; $BAUD_RATES{'extb'} = $BAUD_RATES{'38400'} if exists $BAUD_RATES{'38400'}; } =for markdown [![testsuite](https://github.com/cpan-authors/IO-Stty/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/IO-Stty/actions/workflows/testsuite.yml) =head1 NAME IO::Stty - Change and print terminal line settings =head1 SYNOPSIS # calling the script directly stty.pl [setting...] stty.pl {-a,-g,-v,--version} # Calling Stty module use IO::Stty; IO::Stty::stty(\*TTYHANDLE, @modes); use IO::Stty; $old_mode=IO::Stty::stty(\*STDIN,'-g'); # Turn off echoing. IO::Stty::stty(\*STDIN,'-echo'); # Do whatever.. grab input maybe? $read_password = <>; # Now restore the old mode. IO::Stty::stty(\*STDIN,$old_mode); # What settings do we have anyway? print IO::Stty::stty(\*STDIN,'-a'); =head1 DESCRIPTION This is the PERL POSIX compliant stty. =head1 INTRO This has not been tailored to the IO::File stuff but will work with it as indicated. Before you go futzing with term parameters it's a good idea to grab the current settings and restore them when you finish. stty accepts the following non-option arguments that change aspects of the terminal line operation. A `[-]' before a capability means that it can be turned off by preceding it with a `-'. =head1 stty parameters =head2 Control settings =over 4 =item [-]parenb Generate parity bit in output and expect parity bit in input. =item [-]parodd Set odd parity (even with `-'). =item cs5 cs6 cs7 cs8 Set character size to 5, 6, 7, or 8 bits. =item [-]hupcl [-]hup Send a hangup signal when the last process closes the tty. =item [-]cstopb Use two stop bits per character (one with `-'). =item [-]cread Allow input to be received. =item [-]clocal Disable modem control signals. =back =head2 Input settings =over 4 =item [-]ignbrk Ignore break characters. =item [-]brkint Breaks cause an interrupt signal. =item [-]ignpar Ignore characters with parity errors. =item [-]parmrk Mark parity errors (with a 255-0-character sequence). =item [-]inpck Enable input parity checking. =item [-]istrip Clear high (8th) bit of input characters. =item [-]inlcr Translate newline to carriage return. =item [-]igncr Ignore carriage return. =item [-]icrnl Translate carriage return to newline. =item [-]ixon Enable XON/XOFF flow control. =item [-]ixoff Enable sending of stop character when the system input buffer is almost full, and start character when it becomes almost empty again. =back =head2 Output settings =over 4 =item [-]opost Postprocess output. =back =head2 Local settings =over 4 =item [-]isig Enable interrupt, quit, and suspend special characters. =item [-]icanon Enable erase, kill, werase, and rprnt special characters. =item [-]echo Echo input characters. =item [-]echoe, [-]crterase Echo erase characters as backspace-space-backspace. =item [-]echok Echo a newline after a kill character. =item [-]echonl Echo newline even if not echoing other characters. =item [-]noflsh Disable flushing after interrupt and quit special characters. * Though this claims non-posixhood it is supported by the perl POSIX.pm. =item [-]iexten Enable implementation-defined input processing. This is needed for special characters like werase and lnext to be recognized. =item [-]tostop (np) Stop background jobs that try to write to the terminal. =back =head2 Combination settings =over 4 =item ek Reset the erase and kill special characters to their default values. =item sane Same as: cread -ignbrk brkint -inlcr -igncr icrnl -ixoff opost isig icanon iexten echo echoe echok -echonl -noflsh -tostop also sets all special characters to their default values. =item [-]cooked Same as: brkint ignpar istrip icrnl ixon opost isig icanon plus sets the eof and eol characters to their default values if they are the same as the min and time characters. With `-', same as raw. =item [-]raw Same as: -ignbrk -brkint -ignpar -parmrk -inpck -istrip -inlcr -igncr -icrnl -ixon -ixoff -opost -isig -icanon min 1 time 0 With `-', same as cooked. =item [-]pass8 Same as: -parenb -istrip cs8 With `-', same as parenb istrip cs7. =item crt Same as: echoe echok =item dec Same as: echoe echok Also sets the interrupt special character to Ctrl-C, erase to Del, and kill to Ctrl-U. =item [-]cbreak Same as C<-icanon> (with C<->, same as C). =item evenp, parity Same as: parenb -parodd cs7 =item oddp Same as: parenb parodd cs7 =item -evenp, -parity, -oddp Same as: -parenb cs8 =item [-]litout Same as: -parenb -istrip -opost cs8 With C<->, same as C. =back =head2 Special characters The special characters' default values vary from system to system. They are set with the syntax `name value', where the names are listed below and the value can be given either literally, in hat notation (`^c'), or as an integer which may start with `0x' to indicate hexadecimal, `0' to indicate octal, or any other digit to indicate decimal. Giving a value of `^-' or `undef' disables that special character (sets it to C<_POSIX_VDISABLE>, which is 0 on Linux and 255 on macOS/BSD). =over 4 =item intr Send an interrupt signal. =item quit Send a quit signal. =item erase Erase the last character typed. =item kill Erase the current line. =item eof Send an end of file (terminate the input). =item eol End the line. =item start Restart the output after stopping it. =item stop Stop the output. =item susp Send a terminal stop signal. =back =head2 Special settings =over 4 =item min N Set the minimum number of characters that will satisfy a read until the time value has expired, when C<-icanon> is set. =item time N Set the number of tenths of a second before reads time out if the min number of characters have not been read, when -icanon is set. =item N Set the input and output speeds to N. N can be one of: 0 50 75 110 134 134.5 150 200 300 600 1200 1800 2400 4800 9600 19200 38400 57600 115200 230400 exta extb. 134.5 is the same as 134; exta is the same as 19200; extb is the same as 38400. Modern rates (57600, 115200, 230400) are only available on platforms whose POSIX implementation defines them. 0 hangs up the line if -clocal is set. =back =head2 OPTIONS =over 4 =item -a Print all current settings in human-readable form. =item -g Print all current settings in a form that can be used as an argument to another stty command to restore the current settings. =item speed Print the output baud rate. =item -v,--version Print version info. =back =head1 Direct Subroutines =over 4 =item B<_parse_char_value()> my $numeric = IO::Stty::_parse_char_value($value); Parse a special character value from any of the supported notations: literal integers, hat notation (C<^c>), hexadecimal (C<0x...>), octal (C<0...>), or C/C<^-> to disable (returns C<_POSIX_VDISABLE>). =cut sub _parse_char_value { my ($val) = @_; # undef or ^- means disable the character if ( $val eq 'undef' || $val eq '^-' ) { return $VDISABLE; } # Hat notation: ^c means Ctrl-C (0x03), ^? means DEL (0x7F) if ( $val =~ /^\^(.)$/ ) { my $ch = $1; if ( $ch eq '?' ) { return 0x7F; } return ord( uc($ch) ) & 0x1F; } # Hexadecimal: 0x... if ( $val =~ /^0x([0-9a-fA-F]+)$/ ) { return hex($1); } # Octal: 0 followed by digits (but not plain "0" which is decimal zero) if ( $val =~ /^0(\d+)$/ ) { return oct($1); } # Decimal integer (including plain 0) if ( $val =~ /^\d+$/ ) { return $val + 0; } # Single literal character if ( length($val) == 1 ) { return ord($val); } warn "IO::Stty: unrecognized character value '$val'\n"; return 0; } =item B IO::Stty::stty(\*STDIN, @params); Returns a string for query options (C<-a>, C<-g>, C<-v>), C if the handle is not a terminal or if the terminal parameters could not be read, and a true value on success when setting parameters. From comments: I'm not feeling very inspired about this. Terminal parameters are obscure and boring. Basically what this will do is get the current setting, take the parameters, modify the setting and write it back. Zzzz. This is not especially efficent and probably not too fast. Assuming the POSIX spec has been implemented properly it should mostly work. =cut sub stty { my $tty_handle = shift; # This should be a \*HANDLE @_ or die("No parameters passed to stty"); # Notice fileno() instead of handle->fileno(). I want it to work with # normal fhs. my ($file_num) = fileno($tty_handle); # Is it a terminal? return undef unless isatty($file_num); my ($tty_name) = ttyname($file_num); # make a terminal object. my ($termios) = POSIX::Termios->new(); unless ( $termios->getattr($file_num) ) { warn "Couldn't get terminal parameters for '$tty_name', file num ($file_num)"; return undef; } my ($c_cflag) = $termios->getcflag; my ($c_iflag) = $termios->getiflag; my ($ispeed) = $termios->getispeed; my ($c_lflag) = $termios->getlflag; my ($c_oflag) = $termios->getoflag; my ($ospeed) = $termios->getospeed; my (%control_chars); $control_chars{'INTR'} = $termios->getcc(VINTR); $control_chars{'QUIT'} = $termios->getcc(VQUIT); $control_chars{'ERASE'} = $termios->getcc(VERASE); $control_chars{'KILL'} = $termios->getcc(VKILL); $control_chars{'EOF'} = $termios->getcc(VEOF); $control_chars{'TIME'} = $termios->getcc(VTIME); $control_chars{'MIN'} = $termios->getcc(VMIN); $control_chars{'START'} = $termios->getcc(VSTART); $control_chars{'STOP'} = $termios->getcc(VSTOP); $control_chars{'SUSP'} = $termios->getcc(VSUSP); $control_chars{'EOL'} = $termios->getcc(VEOL); # OK.. we have our crap. my @parameters; if ( @_ == 1 ) { # handle the one-arg cases specifically # Version info if ( $_[0] =~ /^(-v|--version|version)$/ ) { return $IO::Stty::VERSION . "\n"; } elsif ( $_[0] =~ /^\d+$/ || $_[0] eq '134.5' || $_[0] eq 'exta' || $_[0] eq 'extb' ) { push( @parameters, 'ispeed', $_[0], 'ospeed', $_[0] ); } # Print just the output speed (matches GNU stty 'speed') elsif ( $_[0] eq 'speed' ) { my $speed_str = exists $BAUD_SPEEDS{$ospeed} ? $BAUD_SPEEDS{$ospeed} : $ospeed; return "$speed_str\n"; } # Do we want to know what the crap is? elsif ( $_[0] eq '-a' ) { return show_me_the_crap( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed, \%control_chars ); } # did we get the '-g' flag? elsif ( $_[0] eq '-g' ) { return "$c_cflag:$c_iflag:$ispeed:$c_lflag:$c_oflag:$ospeed:" . $control_chars{'INTR'} . ":" . $control_chars{'QUIT'} . ":" . $control_chars{'ERASE'} . ":" . $control_chars{'KILL'} . ":" . $control_chars{'EOF'} . ":" . $control_chars{'TIME'} . ":" . $control_chars{'MIN'} . ":" . $control_chars{'START'} . ":" . $control_chars{'STOP'} . ":" . $control_chars{'SUSP'} . ":" . $control_chars{'EOL'}; } else { # Or the converse.. -g used before and we're getting the return. # Note that this uses the functionality of stty -g, not any specific # method. Don't take the output here and feed it to the OS stty. # This will make perl -w happy. my (@g_params) = split( ':', $_[0] ); if ( @g_params == 17 ) { # print "Feeding back...\n"; ( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed ) = (@g_params); $control_chars{'INTR'} = $g_params[6]; $control_chars{'QUIT'} = $g_params[7]; $control_chars{'ERASE'} = $g_params[8]; $control_chars{'KILL'} = $g_params[9]; $control_chars{'EOF'} = $g_params[10]; $control_chars{'TIME'} = $g_params[11]; $control_chars{'MIN'} = $g_params[12]; $control_chars{'START'} = $g_params[13]; $control_chars{'STOP'} = $g_params[14]; $control_chars{'SUSP'} = $g_params[15]; $control_chars{'EOL'} = $g_params[16]; # leave parameters empty } else { # a simple single option @parameters = @_; } } } else { @parameters = @_; } # So.. what shall we set? my ($set_value); local ($_); while ( defined( $_ = shift(@parameters) ) ) { # print "Param:$_:\n"; # Build the 'this really means this' cases. if ( $_ eq 'ek' ) { unshift( @parameters, 'erase', 8, 'kill', 21 ); next; } if ( $_ eq 'sane' ) { unshift( @parameters, 'cread', '-ignbrk', 'brkint', '-inlcr', '-igncr', 'icrnl', '-ixoff', 'opost', 'isig', 'icanon', 'iexten', 'echo', 'echoe', 'echok', '-echonl', '-noflsh', '-tostop', 'intr', 3, 'quit', 28, 'erase', 8, 'kill', 21, 'eof', 4, 'eol', 'undef', 'stop', 19, 'start', 17, 'susp', 26, 'time', 0, 'min', 0 ); next; # Ugh. } if ( $_ eq 'cooked' || $_ eq '-raw' ) { # Is this right? unshift( @parameters, 'brkint', 'ignpar', 'istrip', 'icrnl', 'ixon', 'opost', 'isig', 'icanon', 'intr', 3, 'quit', 28, 'erase', 8, 'kill', 21, 'eof', 4, 'eol', 'undef', 'stop', 19, 'start', 17, 'susp', 26, 'time', 0, 'min', 0 ); next; } if ( $_ eq 'raw' || $_ eq '-cooked' ) { unshift( @parameters, '-ignbrk', '-brkint', '-ignpar', '-parmrk', '-inpck', '-istrip', '-inlcr', '-igncr', '-icrnl', '-ixon', '-ixoff', '-opost', '-isig', '-icanon', 'min', 1, 'time', 0 ); next; } if ( $_ eq 'pass8' ) { unshift( @parameters, '-parenb', '-istrip', 'cs8' ); next; } if ( $_ eq '-pass8' ) { unshift( @parameters, 'parenb', 'istrip', 'cs7' ); next; } if ( $_ eq 'crt' ) { unshift( @parameters, 'echoe', 'echok' ); next; } if ( $_ eq 'dec' ) { # 127 == delete, no? unshift( @parameters, 'echoe', 'echok', 'intr', 3, 'erase', 127, 'kill', 21 ); next; } if ( $_ eq 'evenp' || $_ eq 'parity' ) { unshift( @parameters, 'parenb', '-parodd', 'cs7' ); next; } if ( $_ eq '-evenp' || $_ eq '-parity' || $_ eq '-oddp' ) { unshift( @parameters, '-parenb', 'cs8' ); next; } if ( $_ eq 'oddp' ) { unshift( @parameters, 'parenb', 'parodd', 'cs7' ); next; } if ( $_ eq 'cbreak' ) { unshift( @parameters, '-icanon' ); next; } if ( $_ eq '-cbreak' ) { unshift( @parameters, 'icanon' ); next; } if ( $_ eq 'litout' ) { unshift( @parameters, '-parenb', '-istrip', '-opost', 'cs8' ); next; } if ( $_ eq '-litout' ) { unshift( @parameters, 'parenb', 'istrip', 'opost', 'cs7' ); next; } $set_value = 1; # On by default... # unset if starts w/ -, as in -crtscts $set_value = 0 if s/^\-//; # Now the fun part. # c_cc field crap. if ( $_ eq 'intr' ) { $control_chars{'INTR'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'quit' ) { $control_chars{'QUIT'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'erase' ) { $control_chars{'ERASE'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'kill' ) { $control_chars{'KILL'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'eof' ) { $control_chars{'EOF'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'eol' ) { $control_chars{'EOL'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'start' ) { $control_chars{'START'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'stop' ) { $control_chars{'STOP'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'susp' ) { $control_chars{'SUSP'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'min' ) { $control_chars{'MIN'} = _parse_char_value( shift @parameters ); next; } if ( $_ eq 'time' ) { $control_chars{'TIME'} = _parse_char_value( shift @parameters ); next; } # c_cflag crap if ( $_ eq 'clocal' ) { $c_cflag = ( $set_value ? ( $c_cflag | CLOCAL ) : ( $c_cflag & ( ~CLOCAL ) ) ); next; } if ( $_ eq 'cread' ) { $c_cflag = ( $set_value ? ( $c_cflag | CREAD ) : ( $c_cflag & ( ~CREAD ) ) ); next; } # As best I can tell, doing |~CS8 will clear the bits.. under solaris # anyway, where CS5 = 0, CS6 = 0x20, CS7= 0x40, CS8=0x60 if ( $_ eq 'cs5' ) { $c_cflag = ( ( $c_cflag & ~CS8 ) | CS5 ); next; } if ( $_ eq 'cs6' ) { $c_cflag = ( ( $c_cflag & ~CS8 ) | CS6 ); next; } if ( $_ eq 'cs7' ) { $c_cflag = ( ( $c_cflag & ~CS8 ) | CS7 ); next; } if ( $_ eq 'cs8' ) { $c_cflag = ( $c_cflag | CS8 ); next; } if ( $_ eq 'cstopb' ) { $c_cflag = ( $set_value ? ( $c_cflag | CSTOPB ) : ( $c_cflag & ( ~CSTOPB ) ) ); next; } if ( $_ eq 'hupcl' || $_ eq 'hup' ) { $c_cflag = ( $set_value ? ( $c_cflag | HUPCL ) : ( $c_cflag & ( ~HUPCL ) ) ); next; } if ( $_ eq 'parenb' ) { $c_cflag = ( $set_value ? ( $c_cflag | PARENB ) : ( $c_cflag & ( ~PARENB ) ) ); next; } if ( $_ eq 'parodd' ) { $c_cflag = ( $set_value ? ( $c_cflag | PARODD ) : ( $c_cflag & ( ~PARODD ) ) ); next; } # That was fun. Still awake? c_iflag time. if ( $_ eq 'brkint' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | BRKINT ) : ( $c_iflag & ( ~BRKINT ) ) ) ); next; } if ( $_ eq 'icrnl' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | ICRNL ) : ( $c_iflag & ( ~ICRNL ) ) ) ); next; } if ( $_ eq 'ignbrk' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | IGNBRK ) : ( $c_iflag & ( ~IGNBRK ) ) ) ); next; } if ( $_ eq 'igncr' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | IGNCR ) : ( $c_iflag & ( ~IGNCR ) ) ) ); next; } if ( $_ eq 'ignpar' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | IGNPAR ) : ( $c_iflag & ( ~IGNPAR ) ) ) ); next; } if ( $_ eq 'inlcr' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | INLCR ) : ( $c_iflag & ( ~INLCR ) ) ) ); next; } if ( $_ eq 'inpck' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | INPCK ) : ( $c_iflag & ( ~INPCK ) ) ) ); next; } if ( $_ eq 'istrip' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | ISTRIP ) : ( $c_iflag & ( ~ISTRIP ) ) ) ); next; } if ( $_ eq 'ixoff' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | IXOFF ) : ( $c_iflag & ( ~IXOFF ) ) ) ); next; } if ( $_ eq 'ixon' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | IXON ) : ( $c_iflag & ( ~IXON ) ) ) ); next; } if ( $_ eq 'parmrk' ) { $c_iflag = ( ( $set_value ? ( $c_iflag | PARMRK ) : ( $c_iflag & ( ~PARMRK ) ) ) ); next; } # Are we there yet? No. Are we there yet? No. Are we there yet... # print "Values: $c_lflag,".($c_lflag | ECHO)." ".($c_lflag & (~ECHO))."\n"; if ( $_ eq 'echo' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ECHO ) : ( $c_lflag & ( ~ECHO ) ) ) ); next; } if ( $_ eq 'echoe' || $_ eq 'crterase' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ECHOE ) : ( $c_lflag & ( ~ECHOE ) ) ) ); next; } if ( $_ eq 'echok' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ECHOK ) : ( $c_lflag & ( ~ECHOK ) ) ) ); next; } if ( $_ eq 'echonl' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ECHONL ) : ( $c_lflag & ( ~ECHONL ) ) ) ); next; } if ( $_ eq 'icanon' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ICANON ) : ( $c_lflag & ( ~ICANON ) ) ) ); next; } if ( $_ eq 'iexten' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | IEXTEN ) : ( $c_lflag & ( ~IEXTEN ) ) ) ); next; } if ( $_ eq 'isig' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | ISIG ) : ( $c_lflag & ( ~ISIG ) ) ) ); next; } if ( $_ eq 'noflsh' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | NOFLSH ) : ( $c_lflag & ( ~NOFLSH ) ) ) ); next; } if ( $_ eq 'tostop' ) { $c_lflag = ( ( $set_value ? ( $c_lflag | TOSTOP ) : ( $c_lflag & ( ~TOSTOP ) ) ) ); next; } # Make it stop! Make it stop! # c_oflag crap. if ( $_ eq 'opost' ) { $c_oflag = ( ( $set_value ? ( $c_oflag | OPOST ) : ( $c_oflag & ( ~OPOST ) ) ) ); next; } # Speed? if ( $_ eq 'ospeed' ) { my $rate = shift(@parameters); exists $BAUD_RATES{$rate} or warn "IO::Stty::stty: unknown baud rate '$rate'\n"; $ospeed = $BAUD_RATES{$rate} if exists $BAUD_RATES{$rate}; next; } if ( $_ eq 'ispeed' ) { my $rate = shift(@parameters); exists $BAUD_RATES{$rate} or warn "IO::Stty::stty: unknown baud rate '$rate'\n"; $ispeed = $BAUD_RATES{$rate} if exists $BAUD_RATES{$rate}; next; } # Default.. parameter hasn't matched anything # print "char:".sprintf("%lo",ord($_))."\n"; warn "IO::Stty::stty passed invalid parameter '$_'\n"; } # What a pain in the ass! Ok.. let's write the crap back. $termios->setcflag($c_cflag); $termios->setiflag($c_iflag); $termios->setispeed($ispeed); $termios->setlflag($c_lflag); $termios->setoflag($c_oflag); $termios->setospeed($ospeed); $termios->setcc( VINTR, $control_chars{'INTR'} ); $termios->setcc( VQUIT, $control_chars{'QUIT'} ); $termios->setcc( VERASE, $control_chars{'ERASE'} ); $termios->setcc( VKILL, $control_chars{'KILL'} ); # On some systems (e.g. Solaris/SVR4), VEOF==VMIN and VEOL==VTIME # share the same cc slot. The slot's meaning depends on ICANON: # canonical mode uses VEOF/VEOL, non-canonical uses VMIN/VTIME. # Writing both would let the second overwrite the first, so we # write only the one that matches the final ICANON state. if (VEOF == VMIN) { if ($c_lflag & ICANON) { $termios->setcc( VEOF, $control_chars{'EOF'} ); } else { $termios->setcc( VMIN, $control_chars{'MIN'} ); } } else { $termios->setcc( VEOF, $control_chars{'EOF'} ); $termios->setcc( VMIN, $control_chars{'MIN'} ); } if (VEOL == VTIME) { if ($c_lflag & ICANON) { $termios->setcc( VEOL, $control_chars{'EOL'} ); } else { $termios->setcc( VTIME, $control_chars{'TIME'} ); } } else { $termios->setcc( VTIME, $control_chars{'TIME'} ); $termios->setcc( VEOL, $control_chars{'EOL'} ); } $termios->setcc( VSTART, $control_chars{'START'} ); $termios->setcc( VSTOP, $control_chars{'STOP'} ); $termios->setcc( VSUSP, $control_chars{'SUSP'} ); return $termios->setattr( $file_num, TCSANOW ); # TCSANOW = do immediately. don't unbuffer first. # OK.. that sucked. } =item B my $output = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed, \%control_chars ); Format terminal settings as a human-readable string, equivalent to C output. Returns a multi-line string showing the current baud rate, special character assignments (in hat notation), and the state of all control, input, output, and local flags. This is the back-end for C. =cut sub _cc_to_hat { my ($val) = @_; return '' if !defined $val || $val == $VDISABLE; return '^?' if $val == 127; return '^' . chr( ord('@') + $val ) if $val >= 0 && $val < 32; return chr($val); } sub show_me_the_crap { my ( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed, $control_chars ) = @_; my (%cc) = %$control_chars; # rs = return string my ($rs) = ''; $rs .= 'speed '; if ( exists $BAUD_SPEEDS{$ospeed} ) { $rs .= $BAUD_SPEEDS{$ospeed}; } else { $rs .= $ospeed; } $rs .= " baud;"; if ( $ispeed != $ospeed ) { $rs .= ' ispeed '; if ( exists $BAUD_SPEEDS{$ispeed} ) { $rs .= $BAUD_SPEEDS{$ispeed}; } else { $rs .= $ispeed; } $rs .= ' baud;'; } $rs .= "\n"; $rs .= 'intr = ' . _cc_to_hat($cc{'INTR'}) . '; quit = ' . _cc_to_hat($cc{'QUIT'}) . '; erase = ' . _cc_to_hat($cc{'ERASE'}) . '; kill = ' . _cc_to_hat($cc{'KILL'}) . ";\n"; $rs .= 'eof = ' . _cc_to_hat($cc{'EOF'}) . '; eol = ' . _cc_to_hat($cc{'EOL'}) . '; start = ' . _cc_to_hat($cc{'START'}) . '; stop = ' . _cc_to_hat($cc{'STOP'}) . '; susp = ' . _cc_to_hat($cc{'SUSP'}) . ";\n"; $rs .= 'min = ' . (defined $cc{'MIN'} ? $cc{'MIN'} : 0) . '; time = ' . (defined $cc{'TIME'} ? $cc{'TIME'} : 0) . ";\n"; # c flags. $rs .= ( ( $c_cflag & CLOCAL ) ? '' : '-' ) . 'clocal '; $rs .= ( ( $c_cflag & CREAD ) ? '' : '-' ) . 'cread '; $rs .= ( ( $c_cflag & CSTOPB ) ? '' : '-' ) . 'cstopb '; $rs .= ( ( $c_cflag & HUPCL ) ? '' : '-' ) . 'hupcl '; $rs .= ( ( $c_cflag & PARENB ) ? '' : '-' ) . 'parenb '; $rs .= ( ( $c_cflag & PARODD ) ? '' : '-' ) . 'parodd '; $c_cflag = $c_cflag & CS8; if ( $c_cflag == CS8 ) { $rs .= "cs8\n"; } elsif ( $c_cflag == CS7 ) { $rs .= "cs7\n"; } elsif ( $c_cflag == CS6 ) { $rs .= "cs6\n"; } else { $rs .= "cs5\n"; } # l flags. $rs .= ( ( $c_lflag & ECHO ) ? '' : '-' ) . 'echo '; $rs .= ( ( $c_lflag & ECHOE ) ? '' : '-' ) . 'echoe '; $rs .= ( ( $c_lflag & ECHOK ) ? '' : '-' ) . 'echok '; $rs .= ( ( $c_lflag & ECHONL ) ? '' : '-' ) . 'echonl '; $rs .= ( ( $c_lflag & ICANON ) ? '' : '-' ) . 'icanon '; $rs .= ( ( $c_lflag & ISIG ) ? '' : '-' ) . 'isig '; $rs .= ( ( $c_lflag & NOFLSH ) ? '' : '-' ) . 'noflsh '; $rs .= ( ( $c_lflag & TOSTOP ) ? '' : '-' ) . 'tostop '; $rs .= ( ( $c_lflag & IEXTEN ) ? '' : '-' ) . 'iexten '; # o flag. jam it after the l flags so it looks more compact. $rs .= ( ( $c_oflag & OPOST ) ? '' : '-' ) . "opost\n"; # i flags. $rs .= ( ( $c_iflag & BRKINT ) ? '' : '-' ) . 'brkint '; $rs .= ( ( $c_iflag & IGNBRK ) ? '' : '-' ) . 'ignbrk '; $rs .= ( ( $c_iflag & IGNPAR ) ? '' : '-' ) . 'ignpar '; $rs .= ( ( $c_iflag & PARMRK ) ? '' : '-' ) . 'parmrk '; $rs .= ( ( $c_iflag & INPCK ) ? '' : '-' ) . 'inpck '; $rs .= ( ( $c_iflag & ISTRIP ) ? '' : '-' ) . 'istrip '; $rs .= ( ( $c_iflag & INLCR ) ? '' : '-' ) . 'inlcr '; $rs .= ( ( $c_iflag & IGNCR ) ? '' : '-' ) . 'igncr '; $rs .= ( ( $c_iflag & ICRNL ) ? '' : '-' ) . 'icrnl '; $rs .= ( ( $c_iflag & IXON ) ? '' : '-' ) . 'ixon '; $rs .= ( ( $c_iflag & IXOFF ) ? '' : '-' ) . "ixoff\n"; return $rs; } =back =head1 AUTHOR Austin Schutz (Initial version and maintenance) Todd Rinaldo (Maintenance) =head1 BUGS This is use at your own risk software. Do anything you want with it except blame me for it blowing up your machine because it's full of bugs. See above for what functions are supported. It's mostly standard POSIX stuff. If any of the settings are wrong and you actually know what some of these extremely arcane settings (like what 'sane' should be in POSIX land) really should be, please open an RT ticket. =head1 ACKNOWLEDGEMENTS None =head1 COPYRIGHT & LICENSE Copyright 1997 Austin Schutz, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; IO-Stty-0.08/scripts/stty.pl000755 000765 000024 00000000365 15160057026 017475 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use IO::Stty; my @params; foreach my $param (@ARGV) { push (@params,split(/\s/,$param)); } my $stty = IO::Stty::stty(\*STDIN,@params); if (defined $stty && $stty ne '0 but true') { print $stty; } IO-Stty-0.08/t/01-cc-to-hat.t000644 000765 000024 00000002561 15163542132 017070 0ustar00todd.rinaldostaff000000 000000 #!perl -T use strict; use warnings; use POSIX (); use Test::More; use IO::Stty; # Determine platform's VDISABLE value (0 on Linux, 255 on macOS/BSD) my $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; # _cc_to_hat is a private sub, call it fully qualified my @tests = ( # [ input, expected, description ] [ undef, '', 'undef value' ], [ $VDISABLE, '', 'VDISABLE value (disabled)' ], [ 1, '^A', 'SOH -> ^A' ], [ 3, '^C', 'ETX -> ^C (intr)' ], [ 4, '^D', 'EOT -> ^D (eof)' ], [ 8, '^H', 'BS -> ^H (erase)' ], [ 21, '^U', 'NAK -> ^U (kill)' ], [ 26, '^Z', 'SUB -> ^Z (susp)' ], [ 31, '^_', 'US -> ^_' ], [ 127, '^?', 'DEL -> ^?' ], [ 65, 'A', 'printable A passes through' ], [ 97, 'a', 'printable a passes through' ], ); # On Linux (VDISABLE=0), 255 is a valid character, not . # On macOS/BSD (VDISABLE=255), 0 is ^@ (NUL), not . if ($VDISABLE == 0) { push @tests, [ 255, chr(255), '255 is valid char when VDISABLE=0' ]; } else { push @tests, [ 0, '^@', '0 (NUL/^@) is valid char when VDISABLE!=0' ]; } plan tests => scalar @tests; for my $t (@tests) { my ( $input, $expected, $desc ) = @$t; is( IO::Stty::_cc_to_hat($input), $expected, "_cc_to_hat: $desc" ); } IO-Stty-0.08/t/01-baud-rate.t000644 000765 000024 00000017044 15160617443 017164 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use POSIX qw(:termios_h); eval { require IO::Pty }; plan skip_all => 'IO::Pty required for baud rate tests' if $@; use IO::Stty; sub fresh_pty { my $pty = IO::Pty->new or die "Cannot create pty: $!"; my $slave = $pty->slave or die "Cannot get slave: $!"; return ( $pty, $slave ); } sub get_termios { my ($fh) = @_; my $t = POSIX::Termios->new; $t->getattr( fileno($fh) ) or die "getattr: $!"; return $t; } # ── 1. Setting a valid baud rate via ospeed ─────────────────────────── subtest 'ospeed sets baud rate on pty' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, 'ospeed', '9600' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B9600(), 'ospeed 9600 takes effect' ); }; subtest 'ispeed sets baud rate on pty' => sub { my ( $pty, $slave ) = fresh_pty(); # Set both speeds in a single stty() call so only one tcsetattr() # fires. Linux pty drivers normalise ispeed to match ospeed during # setattr(); a single call with matching CBAUD/CIBAUD avoids any # intermediate normalisation that two separate calls would expose. IO::Stty::stty( $slave, 'ispeed', '9600', 'ospeed', '9600' ); my $t = get_termios($slave); is( $t->getispeed, POSIX::B9600(), 'ispeed 9600 takes effect' ); }; subtest 'single-arg numeric sets both speeds' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '9600' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B9600(), 'single-arg 9600 sets ospeed' ); is( $t->getispeed, POSIX::B9600(), 'single-arg 9600 sets ispeed' ); }; # ── 2. Baud rate aliases (exta, extb, 134.5) ───────────────────────── subtest 'exta is alias for 19200' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'ospeed', 'exta' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B19200(), 'exta sets ospeed to 19200' ); is( scalar @warnings, 0, 'no warnings for exta' ) or diag "Got warnings: @warnings"; }; subtest 'extb is alias for 38400' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'ospeed', 'extb' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B38400(), 'extb sets ospeed to 38400' ); is( scalar @warnings, 0, 'no warnings for extb' ) or diag "Got warnings: @warnings"; }; subtest '134.5 is alias for B134' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'ospeed', '134.5' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B134(), '134.5 sets ospeed to B134' ); is( scalar @warnings, 0, 'no warnings for 134.5' ) or diag "Got warnings: @warnings"; }; subtest 'single-arg exta sets both speeds' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'exta' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B19200(), 'single-arg exta sets ospeed' ); is( $t->getispeed, POSIX::B19200(), 'single-arg exta sets ispeed' ); is( scalar @warnings, 0, 'no warnings for single-arg exta' ) or diag "Got warnings: @warnings"; }; subtest 'single-arg 134.5 sets both speeds' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, '134.5' ); my $t = get_termios($slave); is( $t->getospeed, POSIX::B134(), 'single-arg 134.5 sets ospeed' ); is( $t->getispeed, POSIX::B134(), 'single-arg 134.5 sets ispeed' ); is( scalar @warnings, 0, 'no warnings for single-arg 134.5' ) or diag "Got warnings: @warnings"; }; # ── 3. Invalid baud rate warns ──────────────────────────────────────── subtest 'unknown baud rate produces warning, does not die' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my $died = !eval { IO::Stty::stty( $slave, 'ospeed', '99999' ); 1; }; ok( !$died, 'stty does not die on unknown rate (old code dies via POSIX autoloader)' ) or diag "died with: $@"; is( scalar @warnings, 1, 'exactly one warning emitted' ); like( ( defined $warnings[0] ? $warnings[0] : '' ), qr/unknown baud rate '99999'/, 'warning mentions the invalid rate' ); }; # ── 3. Regression guard: symbolic dereference in baud rate lookup ────── # # HISTORY: The ospeed/ispeed handlers originally used: # # $ospeed = &{"POSIX::B" . shift(@parameters)}; # # In theory, this pattern allows arbitrary code execution: an attacker # who controls the stty arguments could pass any string and invoke an # arbitrary function in the POSIX:: namespace. However, all public # releases (through 0.04) had 'use strict' enabled without a # 'no strict "refs"' guard, so the symbolic dereference always died at # runtime. This means baud rate setting was completely broken in every # released version — but the vulnerability was never exploitable as # shipped. # # The fix replaced the symbolic dereference with a static %BAUD_RATES # hash built at compile time from known constants. This both fixes the # bug (baud rates actually work now) and prevents the pattern from # becoming exploitable if someone ever removed 'use strict'. # # This test guards against regression by planting a decoy function in # the POSIX namespace and confirming it is never called. subtest 'crafted baud rate cannot call arbitrary POSIX functions' => sub { my ( $pty, $slave ) = fresh_pty(); # Record the speed before the attempt so we can verify it is unchanged. my $t_before = get_termios($slave); my $speed_before = $t_before->getospeed; # Plant a decoy in the POSIX namespace. With the old vulnerable code, # stty($slave, 'ospeed', 'evil_test_probe') would execute: # &{"POSIX::Bevil_test_probe"} # which calls this decoy. The safe hash-based code never resolves the # name, so $decoy_called stays 0. # # There are two failure modes for the old code: # 1. Under 'use strict': dies with "Can't use string as a subroutine ref" # 2. Without strict refs: silently calls the decoy function # The fix must avoid both — no crash AND no arbitrary dispatch. my $decoy_called = 0; no warnings 'once'; local *POSIX::Bevil_test_probe = sub { $decoy_called++; return 42 }; my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my $died = !eval { IO::Stty::stty( $slave, 'ospeed', 'evil_test_probe' ); 1; }; ok( !$died, 'stty with invalid rate does not die (old code croaks on symbolic deref under strict)' ) or diag "died with: $@"; ok( !$decoy_called, 'decoy POSIX::Bevil_test_probe was not called (old code without strict would dispatch it)' ); my $t_after = get_termios($slave); is( $t_after->getospeed, $speed_before, 'ospeed unchanged after rejected rate' ); ok( @warnings >= 1, 'warning emitted for unknown rate' ); like( ( defined $warnings[0] ? $warnings[0] : '' ), qr/unknown baud rate 'evil_test_probe'/, 'warning names the rejected rate' ); }; done_testing; IO-Stty-0.08/t/baud-rates.t000644 000765 000024 00000005416 15163542132 017124 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test::More; use POSIX; use_ok('IO::Stty'); # Test that %BAUD_RATES and %BAUD_SPEEDS are populated correctly. # These are lexical (my) vars in IO::Stty, so we test indirectly via # show_me_the_crap() which uses %BAUD_SPEEDS for display. # Standard POSIX rates and modern rates — availability varies by platform # (e.g. Windows/Strawberry Perl lacks all baud constants) my @standard_rates = qw(0 50 75 110 134 150 200 300 600 1200 1800 2400 4800 9600 19200 38400); my @modern_rates = qw(57600 115200 230400); # Check which rates are available on this platform (informational, not failures) my @available_standard; for my $rate (@standard_rates) { my $const = "POSIX::B$rate"; my $val = eval { no strict 'refs'; &$const() }; if (defined $val) { push @available_standard, $rate; pass("POSIX::B$rate is available on this platform"); } else { pass("POSIX::B$rate is not available on this platform (OK — skipped gracefully)"); } } my @available_modern; for my $rate (@modern_rates) { my $const = "POSIX::B$rate"; my $val = eval { no strict 'refs'; &$const() }; if (defined $val) { push @available_modern, $rate; pass("POSIX::B$rate is available on this platform"); } else { pass("POSIX::B$rate is not available on this platform (OK — skipped gracefully)"); } } # Determine platform's VDISABLE value (0 on Linux, 255 on macOS/BSD) my $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; # Test show_me_the_crap() speed display for each available rate # We need a dummy termios state to call show_me_the_crap() my %dummy_cc = ( INTR => 3, QUIT => 28, ERASE => 127, KILL => 21, EOF => 4, EOL => $VDISABLE, START => 17, STOP => 19, SUSP => 26, MIN => 0, TIME => 0, ); for my $rate (@available_standard, @available_modern) { my $const = "POSIX::B$rate"; my $bval = eval { no strict 'refs'; &$const() }; next unless defined $bval; my $output = IO::Stty::show_me_the_crap( 0, # c_cflag 0, # c_iflag $bval, # ispeed 0, # c_lflag 0, # c_oflag $bval, # ospeed \%dummy_cc, ); like($output, qr/^speed $rate baud;\n/, "show_me_the_crap displays B$rate as '$rate'"); } # Test that an unknown baud rate in stty() produces a warning { my $warned = ''; local $SIG{__WARN__} = sub { $warned = $_[0] }; # We can't easily call stty() without a real terminal, but we can verify # the warning behavior by checking that the module loaded without errors # (the hash-based lookup replaces the unsafe symbolic dereference) ok(1, "Module loaded successfully with hash-based baud rate lookup"); } done_testing(); IO-Stty-0.08/t/01-functional.t000644 000765 000024 00000040752 15163542132 017457 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use POSIX qw(:termios_h); # We need a real tty for IO::Stty — a pty gives us one without needing # an interactive terminal. eval { require IO::Pty }; plan skip_all => 'IO::Pty required for functional tests' if $@; use IO::Stty; # ── helpers ──────────────────────────────────────────────────────────── sub fresh_pty { my $pty = IO::Pty->new or die "Cannot create pty: $!"; my $slave = $pty->slave or die "Cannot get slave: $!"; return ($pty, $slave); } # Return a POSIX::Termios snapshot for $fh. sub get_termios { my ($fh) = @_; my $t = POSIX::Termios->new; $t->getattr(fileno($fh)) or die "getattr: $!"; return $t; } # ── 1. Basic flag toggling ──────────────────────────────────────────── subtest 'toggle echo flag' => sub { my ($pty, $slave) = fresh_pty(); # enable echo, then verify IO::Stty::stty($slave, 'echo'); my $t = get_termios($slave); ok($t->getlflag & ECHO, 'echo is set after stty echo'); # disable echo IO::Stty::stty($slave, '-echo'); $t = get_termios($slave); ok(!($t->getlflag & ECHO), 'echo is cleared after stty -echo'); }; subtest 'toggle multiple flags in one call' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-echo', '-icanon', '-isig'); my $t = get_termios($slave); ok(!($t->getlflag & ECHO), '-echo applied'); ok(!($t->getlflag & ICANON), '-icanon applied'); ok(!($t->getlflag & ISIG), '-isig applied'); IO::Stty::stty($slave, 'echo', 'icanon', 'isig'); $t = get_termios($slave); ok($t->getlflag & ECHO, 'echo re-enabled'); ok($t->getlflag & ICANON, 'icanon re-enabled'); ok($t->getlflag & ISIG, 'isig re-enabled'); }; subtest 'cflag settings (parenb, cs bits)' => sub { my ($pty, $slave) = fresh_pty(); # Some pty drivers (Linux) silently ignore cs7/parenb since ptys don't # do real character framing. Probe first, then test accordingly. IO::Stty::stty($slave, 'cs7'); my $t = get_termios($slave); my $pty_supports_cs7 = (($t->getcflag & CS8) == CS7); SKIP: { skip 'pty driver does not honour cs7/parenb', 2 unless $pty_supports_cs7; IO::Stty::stty($slave, 'cs7', 'parenb'); $t = get_termios($slave); is($t->getcflag & CS8, CS7, 'cs7 set correctly'); ok($t->getcflag & PARENB, 'parenb enabled'); } IO::Stty::stty($slave, 'cs8', '-parenb'); $t = get_termios($slave); is($t->getcflag & CS8, CS8, 'cs8 set correctly'); ok(!($t->getcflag & PARENB), 'parenb disabled'); }; subtest 'iflag settings (icrnl, ixon)' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-icrnl', '-ixon'); my $t = get_termios($slave); ok(!($t->getiflag & ICRNL), '-icrnl applied'); ok(!($t->getiflag & IXON), '-ixon applied'); IO::Stty::stty($slave, 'icrnl', 'ixon'); $t = get_termios($slave); ok($t->getiflag & ICRNL, 'icrnl re-enabled'); ok($t->getiflag & IXON, 'ixon re-enabled'); }; subtest 'igncr toggle' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'igncr'); my $t = get_termios($slave); ok($t->getiflag & IGNCR, 'igncr set'); IO::Stty::stty($slave, '-igncr'); $t = get_termios($slave); ok(!($t->getiflag & IGNCR), 'igncr cleared'); }; subtest '-a output shows igncr' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'igncr'); my $output = IO::Stty::stty($slave, '-a'); like($output, qr/(? sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-opost'); my $t = get_termios($slave); ok(!($t->getoflag & OPOST), '-opost applied'); IO::Stty::stty($slave, 'opost'); $t = get_termios($slave); ok($t->getoflag & OPOST, 'opost re-enabled'); }; # ── 2. -g / restore roundtrip ──────────────────────────────────────── subtest '-g roundtrip preserves settings' => sub { my ($pty, $slave) = fresh_pty(); # Set a known non-default state (skip cs7 — may not stick on ptys) IO::Stty::stty($slave, '-echo', '-icanon', '-opost'); # Capture with -g my $saved = IO::Stty::stty($slave, '-g'); ok(defined $saved, '-g returns a value'); like($saved, qr/^\d+:\d+:\d+:\d+:\d+:\d+/, '-g format is colon-separated integers'); # Count fields: should be 17 (6 flags/speeds + 11 control chars) my @fields = split /:/, $saved; is(scalar @fields, 17, '-g output has 17 fields'); # Now change things back IO::Stty::stty($slave, 'echo', 'icanon', 'opost'); my $t = get_termios($slave); ok($t->getlflag & ECHO, 'echo is back on before restore'); # Restore from -g output IO::Stty::stty($slave, $saved); $t = get_termios($slave); ok(!($t->getlflag & ECHO), 'echo still off after restore'); ok(!($t->getlflag & ICANON), 'icanon still off after restore'); ok(!($t->getoflag & OPOST), 'opost still off after restore'); }; # ── 3. -a human-readable output ────────────────────────────────────── subtest '-a output format' => sub { my ($pty, $slave) = fresh_pty(); my $output = IO::Stty::stty($slave, '-a'); ok(defined $output, '-a returns output'); like($output, qr/speed \d+ baud/, '-a contains speed line'); like($output, qr/echo/, '-a mentions echo'); like($output, qr/icanon/, '-a mentions icanon'); like($output, qr/opost/, '-a mentions opost'); like($output, qr/cs\d/, '-a shows character size'); like($output, qr/intr\s*=/, '-a shows intr control char'); }; # ── 4. Combination settings ────────────────────────────────────────── subtest 'raw mode' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'raw'); my $t = get_termios($slave); # raw should clear these ok(!($t->getiflag & BRKINT), 'raw: -brkint'); ok(!($t->getiflag & ICRNL), 'raw: -icrnl'); ok(!($t->getiflag & IXON), 'raw: -ixon'); ok(!($t->getoflag & OPOST), 'raw: -opost'); ok(!($t->getlflag & ISIG), 'raw: -isig'); ok(!($t->getlflag & ICANON), 'raw: -icanon'); # min=1, time=0 is($t->getcc(VMIN), 1, 'raw: min=1'); is($t->getcc(VTIME), 0, 'raw: time=0'); }; subtest 'cooked mode (opposite of raw)' => sub { my ($pty, $slave) = fresh_pty(); # Start from raw IO::Stty::stty($slave, 'raw'); # Then go cooked IO::Stty::stty($slave, 'cooked'); my $t = get_termios($slave); ok($t->getiflag & BRKINT, 'cooked: brkint set'); ok($t->getiflag & ICRNL, 'cooked: icrnl set'); ok($t->getiflag & IXON, 'cooked: ixon set'); ok($t->getoflag & OPOST, 'cooked: opost set'); ok($t->getlflag & ISIG, 'cooked: isig set'); ok($t->getlflag & ICANON, 'cooked: icanon set'); }; subtest '-raw is same as cooked' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'raw'); IO::Stty::stty($slave, '-raw'); my $t = get_termios($slave); ok($t->getlflag & ICANON, '-raw restores icanon'); ok($t->getlflag & ISIG, '-raw restores isig'); ok($t->getoflag & OPOST, '-raw restores opost'); }; subtest '-cooked is same as raw' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-cooked'); my $t = get_termios($slave); ok(!($t->getlflag & ICANON), '-cooked clears icanon'); ok(!($t->getlflag & ISIG), '-cooked clears isig'); ok(!($t->getoflag & OPOST), '-cooked clears opost'); }; subtest 'sane mode' => sub { my ($pty, $slave) = fresh_pty(); # Scramble things first IO::Stty::stty($slave, 'raw', '-echo'); # Apply sane IO::Stty::stty($slave, 'sane'); my $t = get_termios($slave); ok($t->getlflag & ECHO, 'sane: echo enabled'); ok($t->getlflag & ICANON, 'sane: icanon enabled'); ok($t->getlflag & ISIG, 'sane: isig enabled'); ok($t->getlflag & ECHOE, 'sane: echoe enabled'); ok($t->getlflag & ECHOK, 'sane: echok enabled'); ok($t->getiflag & ICRNL, 'sane: icrnl enabled'); ok($t->getiflag & BRKINT, 'sane: brkint enabled'); ok($t->getoflag & OPOST, 'sane: opost enabled'); ok($t->getcflag & CREAD, 'sane: cread enabled'); ok(!($t->getlflag & ECHONL), 'sane: -echonl'); ok(!($t->getlflag & NOFLSH), 'sane: -noflsh'); # sane sets specific control char values is($t->getcc(VINTR), 3, 'sane: intr=3 (^C)'); is($t->getcc(VQUIT), 28, 'sane: quit=28 (^\\)'); is($t->getcc(VERASE), 8, 'sane: erase=8 (^H)'); is($t->getcc(VKILL), 21, 'sane: kill=21 (^U)'); is($t->getcc(VEOF), 4, 'sane: eof=4 (^D)'); }; subtest 'pass8 / -pass8' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'pass8'); my $t = get_termios($slave); ok(!($t->getcflag & PARENB), 'pass8: -parenb'); ok(!($t->getiflag & ISTRIP), 'pass8: -istrip'); is($t->getcflag & CS8, CS8, 'pass8: cs8'); IO::Stty::stty($slave, '-pass8'); $t = get_termios($slave); # parenb and cs7 may not stick on pty drivers (no real char framing) ok($t->getiflag & ISTRIP, '-pass8: istrip'); SKIP: { skip 'pty driver does not honour parenb/cs7', 2 unless ($t->getcflag & PARENB); ok($t->getcflag & PARENB, '-pass8: parenb'); is($t->getcflag & CS8, CS7, '-pass8: cs7'); } }; subtest 'ek resets erase and kill' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'erase', 42, 'kill', 42); IO::Stty::stty($slave, 'ek'); my $t = get_termios($slave); is($t->getcc(VERASE), 8, 'ek: erase=8'); is($t->getcc(VKILL), 21, 'ek: kill=21'); }; subtest 'dec combination' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'dec'); my $t = get_termios($slave); ok($t->getlflag & ECHOE, 'dec: echoe'); ok($t->getlflag & ECHOK, 'dec: echok'); is($t->getcc(VINTR), 3, 'dec: intr=3'); is($t->getcc(VERASE), 127, 'dec: erase=127 (DEL)'); is($t->getcc(VKILL), 21, 'dec: kill=21'); }; subtest 'crt combination' => sub { my ($pty, $slave) = fresh_pty(); # Clear echoe/echok first so we can verify crt sets them IO::Stty::stty($slave, '-echoe', '-echok'); my $t = get_termios($slave); ok(!($t->getlflag & ECHOE), 'echoe cleared before crt'); IO::Stty::stty($slave, 'crt'); $t = get_termios($slave); ok($t->getlflag & ECHOE, 'crt: echoe set'); ok($t->getlflag & ECHOK, 'crt: echok set'); }; subtest 'crterase alias for echoe' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-crterase'); my $t = get_termios($slave); ok(!($t->getlflag & ECHOE), 'crterase clears ECHOE'); IO::Stty::stty($slave, 'crterase'); $t = get_termios($slave); ok($t->getlflag & ECHOE, 'crterase sets ECHOE'); }; # ── 5. Control character assignment ─────────────────────────────────── subtest 'set control chars by integer' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'intr', 5, 'quit', 30, 'eof', 10); my $t = get_termios($slave); is($t->getcc(VINTR), 5, 'intr set to 5'); is($t->getcc(VQUIT), 30, 'quit set to 30'); is($t->getcc(VEOF), 10, 'eof set to 10'); }; subtest 'set control chars by hat notation' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'intr', '^C', 'quit', '^\\', 'erase', '^?', 'eof', '^D'); my $t = get_termios($slave); is($t->getcc(VINTR), 3, 'intr set to ^C (3)'); is($t->getcc(VQUIT), 28, 'quit set to ^\\ (28)'); is($t->getcc(VERASE), 127, 'erase set to ^? (127)'); is($t->getcc(VEOF), 4, 'eof set to ^D (4)'); }; subtest 'disable control char with undef' => sub { # _POSIX_VDISABLE is the platform-specific value for "disabled" # (0 on Linux, 255 on macOS/BSD) my $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'eol', 'undef'); my $t = get_termios($slave); is($t->getcc(VEOL), $VDISABLE, 'eol disabled via undef (uses _POSIX_VDISABLE)'); IO::Stty::stty($slave, 'eol', '^-'); $t = get_termios($slave); is($t->getcc(VEOL), $VDISABLE, 'eol disabled via ^- (uses _POSIX_VDISABLE)'); }; subtest 'set min and time' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, '-icanon', 'min', 5, 'time', 10); my $t = get_termios($slave); is($t->getcc(VMIN), 5, 'min set to 5'); is($t->getcc(VTIME), 10, 'time set to 10'); }; subtest '-a output shows min and time' => sub { my ($pty, $slave) = fresh_pty(); # min/time are only meaningful in non-canonical mode; on systems where # VEOF==VMIN (e.g. Solaris), setting min/time while ICANON is on would # overwrite the eof/eol slots instead. IO::Stty::stty($slave, '-icanon', 'min', 3, 'time', 7); my $output = IO::Stty::stty($slave, '-a'); like($output, qr/min = 3/, '-a shows min value'); like($output, qr/time = 7/, '-a shows time value'); }; # ── 6. Invalid parameter warning ───────────────────────────────────── subtest 'invalid parameter produces warning' => sub { my ($pty, $slave) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; IO::Stty::stty($slave, 'bogus_flag'); is(scalar @warnings, 1, 'exactly one warning emitted'); like($warnings[0], qr/invalid parameter 'bogus_flag'/, 'warning mentions the bad param'); }; subtest 'valid params mixed with invalid' => sub { my ($pty, $slave) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; # echo should still be applied despite the bogus param IO::Stty::stty($slave, '-echo', 'nonsense', 'icanon'); is(scalar @warnings, 1, 'one warning for nonsense'); like($warnings[0], qr/invalid parameter 'nonsense'/, 'correct param in warning'); my $t = get_termios($slave); ok(!($t->getlflag & ECHO), '-echo still applied despite invalid param'); ok($t->getlflag & ICANON, 'icanon still applied despite invalid param'); }; # ── 7. Version output ──────────────────────────────────────────────── subtest 'version flag' => sub { my ($pty, $slave) = fresh_pty(); my $v = IO::Stty::stty($slave, '-v'); like($v, qr/\d+\.\d+/, '-v returns version string'); }; # ── 8. Non-tty returns undef ───────────────────────────────────────── subtest 'non-tty handle returns undef' => sub { open my $fh, '<', '/dev/null' or die "open /dev/null: $!"; my $result = IO::Stty::stty($fh, '-a'); is($result, undef, 'non-tty returns undef'); close $fh; }; # ── 9. iexten flag ───────────────────────────────────────────────────── subtest 'toggle iexten flag' => sub { my ($pty, $slave) = fresh_pty(); IO::Stty::stty($slave, 'iexten'); my $t = get_termios($slave); ok($t->getlflag & IEXTEN, 'iexten is set after stty iexten'); IO::Stty::stty($slave, '-iexten'); $t = get_termios($slave); ok(!($t->getlflag & IEXTEN), 'iexten is cleared after stty -iexten'); }; # ── 10. Return value on set operations ───────────────────────────────── subtest 'stty returns true on successful set' => sub { my ($pty, $slave) = fresh_pty(); my $result = IO::Stty::stty($slave, 'echo'); ok($result, 'stty returns true value when setting flags'); }; # ── 11. iexten shown in -a output ───────────────────────────────────── subtest 'iexten appears in -a output' => sub { my ($pty, $slave) = fresh_pty(); my $output = IO::Stty::stty($slave, '-a'); like($output, qr/-?iexten/, '-a output includes iexten'); }; done_testing; IO-Stty-0.08/t/02-show-me-the-crap.t000644 000765 000024 00000005715 15163542132 020376 0ustar00todd.rinaldostaff000000 000000 #!perl -T use strict; use warnings; use Test::More; use IO::Stty; use POSIX (); my ( $CS8, $B9600 ); eval { $CS8 = POSIX::CS8(); $B9600 = POSIX::B9600(); 1 } or plan skip_all => 'POSIX termios constants not available on this platform'; plan tests => 9; # Determine platform's VDISABLE value (0 on Linux, 255 on macOS/BSD) my $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; # Build a minimal set of arguments for show_me_the_crap. # Flags are all zero so every flag prints with '-' prefix. my $c_cflag = $CS8; my $c_iflag = 0; my $c_lflag = 0; my $c_oflag = 0; my $ispeed = $B9600; my $ospeed = $B9600; my %cc = ( INTR => 3, # ^C QUIT => 28, # ^\ ERASE => 127, # ^? KILL => 21, # ^U EOF => 4, # ^D EOL => $VDISABLE, # (disabled) START => 17, # ^Q STOP => 19, # ^S SUSP => 26, # ^Z MIN => 1, TIME => 0, ); my $output = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $ispeed, $c_lflag, $c_oflag, $ospeed, \%cc, ); like( $output, qr/^speed 9600 baud;$/m, 'output contains speed line' ); like( $output, qr/^intr = \^C; quit = \^\\; erase = \^\?; kill = \^U;$/m, 'control chars line 1 uses hat notation', ); like( $output, qr/^eof = \^D; eol = ; start = \^Q; stop = \^S; susp = \^Z;$/m, 'control chars line 2 uses hat notation', ); like( $output, qr/^min = 1; time = 0;$/m, 'min and time values displayed', ); # Unknown ospeed falls back to raw numeric value (e.g. OpenBSD ptys) { my $bogus_speed = 99999; my $out = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $bogus_speed, $c_lflag, $c_oflag, $bogus_speed, \%cc, ); like( $out, qr/^speed 99999 baud;$/m, 'unknown ospeed shows raw numeric value' ); } # When ispeed differs from ospeed, ispeed is shown separately { my $bogus_ispeed = 77777; my $out = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $bogus_ispeed, $c_lflag, $c_oflag, $ospeed, \%cc, ); like( $out, qr/ispeed 77777 baud;/m, 'unknown ispeed shows raw numeric value' ); } # When ispeed differs but is a known baud rate, ispeed shows symbolic value { my $B4800 = eval { POSIX::B4800() }; SKIP: { skip 'B4800 not available', 1 unless defined $B4800; my $out = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $B4800, $c_lflag, $c_oflag, $ospeed, \%cc, ); like( $out, qr/ispeed 4800 baud;/m, 'known ispeed shows symbolic baud rate' ); } } # When ispeed equals ospeed, no separate ispeed is shown { my $out = IO::Stty::show_me_the_crap( $c_cflag, $c_iflag, $ospeed, $c_lflag, $c_oflag, $ospeed, \%cc, ); unlike( $out, qr/ispeed/, 'ispeed not shown when equal to ospeed' ); } # Every settable iflag should appear in -a output (igncr was missing before) like( $output, qr/-igncr/, '-a output includes igncr flag' ); IO-Stty-0.08/t/01-parse-char-value.t000644 000765 000024 00000003356 15161556561 020464 0ustar00todd.rinaldostaff000000 000000 #!perl use strict; use warnings; use Test::More; use POSIX (); use IO::Stty; # _POSIX_VDISABLE: the platform-specific value used to disable a cc slot my $VDISABLE = eval { POSIX::_POSIX_VDISABLE() }; $VDISABLE = 0 unless defined $VDISABLE; # _parse_char_value is a private sub, call it fully qualified my @tests = ( # [ input, expected, description ] # Plain decimal integers [ '0', 0, 'decimal zero' ], [ '3', 3, 'decimal 3' ], [ '127', 127, 'decimal 127' ], [ '21', 21, 'decimal 21' ], # Hat notation [ '^C', 3, 'hat notation ^C (Ctrl-C)' ], [ '^c', 3, 'hat notation ^c (lowercase)' ], [ '^D', 4, 'hat notation ^D (Ctrl-D / EOF)' ], [ '^?', 0x7F, 'hat notation ^? (DEL)' ], [ '^A', 1, 'hat notation ^A' ], [ '^Z', 26, 'hat notation ^Z (Ctrl-Z / SUSP)' ], [ '^@', 0, 'hat notation ^@ (NUL)' ], [ '^[', 27, 'hat notation ^[ (ESC)' ], # Hexadecimal [ '0x03', 3, 'hex 0x03' ], [ '0x7f', 127, 'hex 0x7f (lowercase)' ], [ '0x7F', 127, 'hex 0x7F (uppercase)' ], [ '0x1B', 27, 'hex 0x1B' ], [ '0x00', 0, 'hex 0x00' ], [ '0xff', 255, 'hex 0xff' ], # Octal [ '03', 3, 'octal 03' ], [ '010', 8, 'octal 010' ], [ '017', 15, 'octal 017' ], [ '0177', 127, 'octal 0177' ], # undef / ^- (returns _POSIX_VDISABLE, which is 0 on Linux, 255 on macOS) [ 'undef', $VDISABLE, 'undef disables character (returns _POSIX_VDISABLE)' ], [ '^-', $VDISABLE, '^- disables character (returns _POSIX_VDISABLE)' ], ); plan tests => scalar @tests; for my $test (@tests) { my ( $input, $expected, $desc ) = @$test; my $got = IO::Stty::_parse_char_value($input); is( $got, $expected, $desc ); } IO-Stty-0.08/t/99-pod-coverage.t000644 000765 000024 00000000527 15161476317 017716 0ustar00todd.rinaldostaff000000 000000 #!perl use strict; use warnings; use Test::More; plan skip_all => "\$ENV{RELEASE_TESTING} required for these tests" if(!$ENV{RELEASE_TESTING}); eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; plan tests => 1; pod_coverage_ok('IO::Stty', "IO::Stty pod coverage"); IO-Stty-0.08/t/99-pod.t000644 000765 000024 00000000411 15161476317 016115 0ustar00todd.rinaldostaff000000 000000 #!perl -T use strict; use warnings; use Test::More; plan skip_all => "\$ENV{RELEASE_TESTING} required for these tests" if(!$ENV{RELEASE_TESTING}); eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); IO-Stty-0.08/t/00-load.t000644 000765 000024 00000000246 15161476317 016236 0ustar00todd.rinaldostaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'IO::Stty' ); } diag( "Testing IO::Stty $IO::Stty::VERSION, Perl $], $^X" ); IO-Stty-0.08/t/02-single-arg.t000644 000765 000024 00000011352 15163542132 017340 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use POSIX qw(:termios_h); eval { require IO::Pty }; plan skip_all => 'IO::Pty required for terminal tests' if $@; use IO::Stty; sub fresh_pty { my $pty = IO::Pty->new or die "Cannot create pty: $!"; my $slave = $pty->slave or die "Cannot get slave: $!"; return ( $pty, $slave ); } sub get_termios { my ($fh) = @_; my $t = POSIX::Termios->new; $t->getattr( fileno($fh) ) or die "getattr: $!"; return $t; } # ── Single numeric arg sets baud rate ──────────────────────────────── # This was broken: the if/elsif chain had a separate if/else for -g # that fell through and overwrote @parameters for numeric args. subtest 'single numeric arg sets ispeed and ospeed' => sub { my ( $pty, $slave ) = fresh_pty(); # Capture warnings — before the fix, this produced # "IO::Stty::stty passed invalid parameter '9600'" my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, '9600' ); is( scalar @warnings, 0, 'no warnings from numeric baud rate arg' ) or diag "Got warnings: @warnings"; my $t = get_termios($slave); is( $t->getospeed, POSIX::B9600(), 'ospeed set to B9600' ); is( $t->getispeed, POSIX::B9600(), 'ispeed set to B9600' ); }; # ── -g save/restore round-trip ─────────────────────────────────────── subtest '-g save and restore round-trip' => sub { my ( $pty, $slave ) = fresh_pty(); # Save current settings my $saved = IO::Stty::stty( $slave, '-g' ); ok( defined $saved, '-g returns defined value' ); my @parts = split /:/, $saved; is( scalar @parts, 17, '-g output has 17 colon-separated fields' ); # Change something IO::Stty::stty( $slave, '-echo' ); my $t = get_termios($slave); ok( !( $t->getlflag & ECHO ), 'echo disabled' ); # Restore IO::Stty::stty( $slave, $saved ); $t = get_termios($slave); # The restored lflag should match what was saved is( $t->getlflag, $parts[3], 'lflag restored to saved value' ); }; # ── -a output ──────────────────────────────────────────────────────── subtest '-a returns human-readable output' => sub { my ( $pty, $slave ) = fresh_pty(); my $output = IO::Stty::stty( $slave, '-a' ); ok( defined $output, '-a returns defined value' ); like( $output, qr/speed \d+ baud/, 'contains speed line' ); like( $output, qr/echo/, 'contains echo setting' ); }; # ── -v returns version ─────────────────────────────────────────────── subtest '-v returns version' => sub { my ( $pty, $slave ) = fresh_pty(); my $ver = IO::Stty::stty( $slave, '-v' ); is( $ver, $IO::Stty::VERSION . "\n", '-v returns VERSION' ); }; subtest '--version returns version' => sub { my ( $pty, $slave ) = fresh_pty(); my $ver = IO::Stty::stty( $slave, '--version' ); is( $ver, $IO::Stty::VERSION . "\n", '--version returns VERSION' ); }; subtest 'version (bare) returns version' => sub { my ( $pty, $slave ) = fresh_pty(); my $ver = IO::Stty::stty( $slave, 'version' ); is( $ver, $IO::Stty::VERSION . "\n", 'bare version returns VERSION' ); }; # ── speed query ────────────────────────────────────────────────────── subtest 'speed returns output baud rate' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '9600' ); my $speed = IO::Stty::stty( $slave, 'speed' ); is( $speed, "9600\n", 'speed returns symbolic baud rate' ); }; subtest 'speed with unknown rate returns raw numeric' => sub { my ( $pty, $slave ) = fresh_pty(); # Just verify speed returns something reasonable for default pty speed my $speed = IO::Stty::stty( $slave, 'speed' ); ok( defined $speed, 'speed returns a defined value' ); like( $speed, qr/^\d+\n$/, 'speed output is a number followed by newline' ); }; # ── single flag arg works ──────────────────────────────────────────── subtest 'single flag arg (not numeric, not special)' => sub { my ( $pty, $slave ) = fresh_pty(); # Set echo, then pass single '-echo' arg IO::Stty::stty( $slave, 'echo' ); IO::Stty::stty( $slave, '-echo' ); my $t = get_termios($slave); ok( !( $t->getlflag & ECHO ), 'single -echo arg works' ); }; done_testing; IO-Stty-0.08/t/02-combination-aliases.t000644 000765 000024 00000014413 15161476317 021243 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use POSIX qw(:termios_h); eval { require IO::Pty }; plan skip_all => 'IO::Pty required for terminal tests' if $@; use IO::Stty; sub fresh_pty { my $pty = IO::Pty->new or die "Cannot create pty: $!"; my $slave = $pty->slave or die "Cannot get slave: $!"; return ( $pty, $slave ); } sub get_termios { my ($fh) = @_; my $t = POSIX::Termios->new; $t->getattr( fileno($fh) ) or die "getattr: $!"; return $t; } # ── cbreak / -cbreak ──────────────────────────────────────────────── subtest 'cbreak disables icanon' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, 'icanon' ); my $t = get_termios($slave); ok( $t->getlflag & ICANON, 'icanon starts on' ); IO::Stty::stty( $slave, 'cbreak' ); $t = get_termios($slave); ok( !( $t->getlflag & ICANON ), 'cbreak clears icanon' ); }; subtest '-cbreak enables icanon' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '-icanon' ); my $t = get_termios($slave); ok( !( $t->getlflag & ICANON ), 'icanon starts off' ); IO::Stty::stty( $slave, '-cbreak' ); $t = get_termios($slave); ok( $t->getlflag & ICANON, '-cbreak sets icanon' ); }; # ── evenp / parity ────────────────────────────────────────────────── subtest 'evenp sets parenb -parodd cs7' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'evenp' ); is( scalar @warnings, 0, 'no warnings' ) or diag "Got: @warnings"; my $t = get_termios($slave); SKIP: { skip 'pty driver does not honour parenb/cs7', 3 unless ( $t->getcflag & PARENB ); ok( $t->getcflag & PARENB, 'evenp: parenb set' ); ok( !( $t->getcflag & PARODD ), 'evenp: -parodd' ); is( $t->getcflag & CS8, CS7, 'evenp: cs7' ); } }; subtest 'parity is same as evenp' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'parity' ); is( scalar @warnings, 0, 'no warnings' ) or diag "Got: @warnings"; my $t = get_termios($slave); SKIP: { skip 'pty driver does not honour parenb/cs7', 3 unless ( $t->getcflag & PARENB ); ok( $t->getcflag & PARENB, 'parity: parenb set' ); ok( !( $t->getcflag & PARODD ), 'parity: -parodd' ); is( $t->getcflag & CS8, CS7, 'parity: cs7' ); } }; # ── oddp ──────────────────────────────────────────────────────────── subtest 'oddp sets parenb parodd cs7' => sub { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, 'oddp' ); is( scalar @warnings, 0, 'no warnings' ) or diag "Got: @warnings"; my $t = get_termios($slave); SKIP: { skip 'pty driver does not honour parenb/parodd/cs7', 3 unless ( $t->getcflag & PARENB ); ok( $t->getcflag & PARENB, 'oddp: parenb set' ); ok( $t->getcflag & PARODD, 'oddp: parodd set' ); is( $t->getcflag & CS8, CS7, 'oddp: cs7' ); } }; # ── -evenp / -parity / -oddp ─────────────────────────────────────── subtest '-evenp clears parenb and sets cs8' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '-evenp' ); my $t = get_termios($slave); ok( !( $t->getcflag & PARENB ), '-evenp: -parenb' ); is( $t->getcflag & CS8, CS8, '-evenp: cs8' ); }; subtest '-parity clears parenb and sets cs8' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '-parity' ); my $t = get_termios($slave); ok( !( $t->getcflag & PARENB ), '-parity: -parenb' ); is( $t->getcflag & CS8, CS8, '-parity: cs8' ); }; subtest '-oddp clears parenb and sets cs8' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, '-oddp' ); my $t = get_termios($slave); ok( !( $t->getcflag & PARENB ), '-oddp: -parenb' ); is( $t->getcflag & CS8, CS8, '-oddp: cs8' ); }; # ── litout / -litout ─────────────────────────────────────────────── subtest 'litout sets -parenb -istrip -opost cs8' => sub { my ( $pty, $slave ) = fresh_pty(); IO::Stty::stty( $slave, 'litout' ); my $t = get_termios($slave); ok( !( $t->getcflag & PARENB ), 'litout: -parenb' ); ok( !( $t->getiflag & ISTRIP ), 'litout: -istrip' ); ok( !( $t->getoflag & OPOST ), 'litout: -opost' ); is( $t->getcflag & CS8, CS8, 'litout: cs8' ); }; subtest '-litout sets parenb istrip opost cs7' => sub { my ( $pty, $slave ) = fresh_pty(); # Start from litout so we can verify the reverse IO::Stty::stty( $slave, 'litout' ); IO::Stty::stty( $slave, '-litout' ); my $t = get_termios($slave); ok( $t->getiflag & ISTRIP, '-litout: istrip set' ); ok( $t->getoflag & OPOST, '-litout: opost set' ); SKIP: { skip 'pty driver does not honour parenb/cs7', 2 unless ( $t->getcflag & PARENB ); ok( $t->getcflag & PARENB, '-litout: parenb set' ); is( $t->getcflag & CS8, CS7, '-litout: cs7' ); } }; # ── no warnings for any of these ─────────────────────────────────── subtest 'no invalid parameter warnings for new combos' => sub { my @combos = qw( evenp parity oddp -evenp -parity -oddp cbreak -cbreak litout -litout ); for my $combo (@combos) { my ( $pty, $slave ) = fresh_pty(); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; IO::Stty::stty( $slave, $combo ); is( scalar @warnings, 0, "no warnings for '$combo'" ) or diag "Got: @warnings"; } }; done_testing;