diff --git a/0001-Extend-the-Test-Timeout-Period.patch b/0001-Extend-the-Test-Timeout-Period.patch new file mode 100644 index 0000000000000000000000000000000000000000..eb43445134d4d2e5ce3e900cfa587d9fd4aaac9f --- /dev/null +++ b/0001-Extend-the-Test-Timeout-Period.patch @@ -0,0 +1,25 @@ +From 1cda3dc1f541d8c8c921d8f9e4ad3f3d060527c0 Mon Sep 17 00:00:00 2001 +From: xinhaitao +Date: Tue, 28 Oct 2025 01:55:00 -0400 +Subject: [PATCH] Extend the Test Timeout Period + +--- + t/test.t | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/t/test.t b/t/test.t +index f61a978..ac3a219 100644 +--- a/t/test.t ++++ b/t/test.t +@@ -185,7 +185,7 @@ diag( + my $sendbuf = $s; + $SIG{ALRM} = $SIG{TERM} = $SIG{INT} = sub { die "TIMEOUT(SIG" . shift() . ")"; }; + eval { +- alarm(15); ++ alarm(25); + + while ( $sendbuf or length($ret) < length($s) ) { + if ($sendbuf) { +-- +2.41.0 + diff --git a/perl-IO-Tty-c99.patch b/perl-IO-Tty-c99.patch new file mode 100644 index 0000000000000000000000000000000000000000..99b9fdaaeafe75c5d426d4d9503175f824598a6e --- /dev/null +++ b/perl-IO-Tty-c99.patch @@ -0,0 +1,48 @@ +commit 1735a78561dbe139fd138caef2d44d81f5494fe7 +Author: Khem Raj +Date: Tue Apr 4 12:28:11 2023 -0700 + + Make function checks more robust within shared libs + + Previous attempt to error at link like was with + + https://github.com/toddr/IO-Tty/commit/1747cdf9f98cfd3aada9bf6c09f9d46297e18a5e + + this however causes issues with newer clang where it detects + the assignment as -Wint-conversion warning which is treated at error + and builds with clang fail. So this is an attempt to instruct + linker explicitly to error out if the symbol is not found during link + time when building a shared library, this fixes both the problems + as reported in + + https://github.com/toddr/IO-Tty/issues/23 + + as well as + + https://github.com/toddr/IO-Tty/pull/33#issuecomment-1260147256 + + Signed-off-by: Khem Raj + +diff --git a/Makefile.PL b/Makefile.PL +index 6b1b6fab1a57f457..2efb6f9bb54d7ff8 100644 +--- a/Makefile.PL ++++ b/Makefile.PL +@@ -163,7 +163,8 @@ main () + #if defined (__stub_$f) || defined (__stub___$f) + choke me + #else +-f = $f (); ++f = $f; ++f(); + #endif + + ; +@@ -173,7 +174,7 @@ ESQ + + close(TST); + print "Looking for $f()" . "." x (13-length($f)) . " "; +- if (system("$cfg{'cc'} $flags $funcs{$f} functest_$f.c > functest_$f.log 2>&1")) { ++ if (system("$cfg{'cc'} $flags -Wl,--no-undefined $funcs{$f} functest_$f.c > functest_$f.log 2>&1")) { + print "not found.\n"; + } else { + $define{"-DHAVE_\U$f"} = undef; diff --git a/perl-IO-Tty.spec b/perl-IO-Tty.spec index ab56d309cdc8a9127f0ff2ef64daf5c56a1c682e..ddc64ad3867780c9e31568efac5d4e61da6da02b 100644 --- a/perl-IO-Tty.spec +++ b/perl-IO-Tty.spec @@ -1,4 +1,4 @@ -%define anolis_release 1 +%define anolis_release 2 Name: perl-IO-Tty Version: 1.17 Release: %{anolis_release}%{?dist} @@ -6,6 +6,8 @@ Summary: Perl interface to pseudo tty's License: (GPL-1.0-or-later OR Artistic-1.0-Perl) AND BSD-2-Clause URL: https://metacpan.org/release/IO-Tty Source0: https://cpan.metacpan.org/modules/by-module/IO/IO-Tty-%{version}.tar.gz +Patch0: perl-IO-Tty-c99.patch +Patch1: 0001-Extend-the-Test-Timeout-Period.patch # Module Build BuildRequires: coreutils BuildRequires: findutils @@ -47,6 +49,7 @@ The %{name}-doc package contains documentation files for %{name}. %prep %setup -q -n IO-Tty-%{version} +%autosetup -p1 -n IO-Tty-%{version} %build perl Makefile.PL INSTALLDIRS=vendor OPTIMIZE="%{optflags}" NO_PACKLIST=1 NO_PERLLOCAL=1 @@ -71,5 +74,8 @@ find %{buildroot} -type f -name '*.bs' -empty -delete %doc ChangeLog README %changelog +* Tue Oct 28 2025 Xinhaitao - 1.17-2 +- Backport upstream patch to fix C99 compatibility issue + * Mon Jan 30 2023 Funda Wang - 1.17-1 - Import package for anolis 23 diff --git a/src/IO-Tty-1.17/ChangeLog b/src/IO-Tty-1.17/ChangeLog new file mode 100644 index 0000000000000000000000000000000000000000..a09b3ba74ecb759f385ffd00d319e98a90152443 --- /dev/null +++ b/src/IO-Tty-1.17/ChangeLog @@ -0,0 +1,287 @@ +1.17 2022-11-11 Todd Rinaldo + * Switch changelog entries to metacpan friendly format + * #29 - Fix printf format conversion specifiers in croak to support size_t on all platforms + * #11,#30 - Tty.pm: pre-allocate buffer for ioctl but leave it length 0 + * #28 - Use $arg to match @ARGV in Makefile.PL + +1.16 2021-01-2 Todd Rinaldo + * Switch to github for issue tracker. + * Switch to testsuite CI workflow. + * Tidy + +1.15 2020-10-03 Todd Rinaldo + * Skip winsize test on Solaris and QNX NTO + * Make function tests more robust + * Work around a header name collission on util.h. This is breaking on recent OSX + +1.15 2020-01-18 Todd Rinaldo + * Add strict/warnings to Tty.pm + * Fix pod errors + * Typo: s/dependend/dependent/ + * Prevent spurious warning from get_winsize() + * Fix usage of setsid + * Github actions testing. Windows is off of course. + * Make README.md + +1.13_01 2014-12-14 Todd Rinaldo + * RT 91590 - Remove MAP_TARGET from Makefile.PL + * RT 88271 - Fix for Solaris setuid when root running as other user + +1.12 2014-09-12 Todd Rinaldo + * Merge pull request from Chris Williams (bingos) to fix "redefinition of typedef" errors with v5.19.4 and above + +1.11 2014-05-05 Todd Rinaldo + * Release 1.11 to CPAN with explicit dropping of support for Win32 (we never supported it) - RT 77813 + * Bump version to a devel release 1.11_01 for experimental work. + * Fix typo in compilter - RT 75649 + * Add support for PERL_MM_OPT + +1.10 2010-10-11 Todd Rinaldo + * CPAN testers clean. Bumping to release version 1.10 + +1.09_01 2010-10-04 Todd Rinaldo + * RT 60788 - Better error reporting on Operating Systems + that can't set a controlling terminal e.g. BeOS + * Bump to 1.09_01 + +1.09 2010-10-04 Todd Rinaldo + * CPAN testers looks clean. Internal testing done on perl 5.6 + * Bump version to 1.09 and release to CPAN + +1.08_03 2010-10-02 Todd Rinaldo + * RT 61642 - Fix file number test to work without hang on cygwin + * Bump to 1.08_03 + +1.08_02 2010-09-10 Todd Rinaldo + * Update all versions to the new version. bump to 1.08_02 + +1.08_01 2010-09-10 Todd Rinaldo + * RT 45008 - only try TIOCSCTTY if we don't have a ctty + * RT 53883 - IO::Tty detection on BeOS w/fix + * RT 60014 - better META.yml by modernizing Makefile.PL + * RT 44771 - Add _ to list of escape characters for compiler + so it'll compile on windows This is experimental pending a + successful dev release + +v1.08 2009-02-05 Roland Giersig + * Makefile.PL, Tty.xs: added support for posix_openpt(), thanks to Ed Schouten for providing a patch + +v1.07 2006-07-18 Roland Giersig + * Tty.xs: added some more letter to BSD allocation + +v1.06 2006-07-15 Roland Giersig + * Tty.pm: pre-allocate buffer for ioctl + +v1.05 2006-06-06 Roland Giersig + * Tty.xs: added includes and + +v1.04 2006-05-28 Roland Giersig + * Tty.xs: added handling for z/OS (uses /dev/ptyp0000) + * Makefile.PL: added (for HPUX) + +v1.03 2006-04-25 Roland Giersig + * Tty.c: changed newCONSTSUB to use newSV(0) instead of PL_sv_undef, now undef'd constants work + * Makefile.PL: made ccflags handling meta-char safe, added ldflags; enhanced error msg + * Makefile.PL: added + +v1.02 2002-04-02 Roland Giersig + * Tty.pm, Pty.pm: v1.02; disable warning for non-existant die handler + +v1.01 2002-03-18 Roland Giersig + * Makefile.PL: remove cpp, test-compile instead + * Tty.pm, Pty.pm: disable die handler when requiring Stty + +v0.97_04 2002-03-06 Roland Giersig + * v0.97_04, final pre-release version + +v0.97_03 2002-03-04 Roland Giersig + * Pty.pm: v0.97_03 + * Makefile.PL: order of include files is preserved; added test for + working cpp. + * Tty.pm (clone_winsize_from): v0.97_03; added function. + * Tty.xs (allocate_pty): fixed typo in close for _getpty; changed order of termios.h and termio.h includes + +2002-02-26 Roland Giersig + + * test.pl: replaced Test.pm + + * Tty.pm (set_raw): v0.97_01; moved set_raw() from test to method + + * Tty.xs: got rid of snprintf; don't try openpty() and getpt() if + ptsname is not there. + + * Pty.pm: v0.97_01; updated docs + + * Makefile.PL: v0.97_01; auto-create IO::Tty::Constant + +2002-01-31 Roland Giersig + + * Pty.pm: add IO::Stty to @ISA, master pty is sometimes a tty. + + * Tty.pm: v0.95_01 + +2002-01-30 Roland Giersig + + * Tty.pm, Pty.pm: v0.94_05 + + * Tty.xs (allocate_pty): moved getpt() and openpty() before muxes + + * test.pl: if master isatty, set it also to raw; seems to be needed. + + * Makefile.PL: fixed checks; test problematic constants with a compile. + +2002-01-23 Roland Giersig + + * Tty.pm: v0.94_03 + + * test.pl: changed test to probe for maximum chunk the pty can + handle; also, the /dev/tty test probes if an EOF is correctly + reported from the child to the parent. + + * Tty.xs: finally made debug printfs optional via $IO::Tty::DEBUG. + +2002-01-18 Roland Giersig + + * Tty.pm: v0.94_02 + + * Tty.xs: added #include termio.h + +2002-01-07 Roland Giersig + + * Pty.pm: adapted to new interface + (close_slave): added for keeping open filecount straight + (make_slave_controlling_terminal): created anew + (slave): reverted from open_slave() + + * Tty.pm: v0.94_01 + + * test.pl: adapted to new interface + + * Tty.xs: reverted to opening slave at creation time; added debug + printfs + (open_slave): use ptsname_r if there, forget about erroneous ttyname. + (allocate_pty): added name param on openpty (doesn't take NULL for name) + +2001-11-28 Roland Giersig + + * Tty.pm: v0.92_04 + + * Tty.xs (BOOT): use perl_get_sv for backward compat + + * Makefile.PL: added analysis of configuration + +2001-11-27 Roland Giersig + + * Tty.pm: v0.92_03 + + * Tty.xs (BOOT): removed export_fail, undefined constants are now + undef instead of not exportable; added CONFIG variable. + + * Makefile.PL: added setting of CONFIG var + + * test.pl: added printing of CONFIG var + + * Pty.pm (spawn): fixed bug with $^W handling + +2001-11-17 Roland Giersig + + * Tty.xs (pty_allocate): complete rewrite, based on ideas from + openssh and Xemacs. Tries all ways detected by Makefile.PL in + order, so in theory it should work everywhere (modulo system + quirks). First tries the high-level openpty() before getpt(), + then various clone devices and finally BSD-style ptys. + + * Tty.xs (open_slave): moved master init stuff here, must be done + before opening the slave. The Stream module pushes are now tried + on all systems but only generate warnings on systems that we know + need them. + + * Makefile.PL: added tests for all kinds of functions and clone + devices. + +2001-11-14 Roland Giersig + + * Tty.xs (MODULE): stole creation code from openssh + + * test.pl: added test for controlling terminal + + * Pty.pm (spawn): rearranged setsid() and added a fresh open of + the slave pty so the pty becomes the controlling terminal for the + process. + +2001-10-25 Roland Giersig + + * Pty.pm (spawn): copied spawning process from Tcl/Expect (thanks, + Don!); should set the controlling tty so ssh and other password + requesting programs should be OK; also now returns exec errors. + (slave_pid): added method to get at PID of spawned process. + + * Makefile.PL: added TIOCCONS. + + * try: adapted to use spawn(). + + * test.pl: adapted to use spawn(); added test for exec errors. + +2001-10-16 Roland Giersig + + * Pty.pm (new): fixed bad my() line + + * automatically add IO::Stty to ISA if it exists. + +2001-07-16 Roland Giersig + + * test.pl: finally some tests! Spawns a perl mini-script that + echoes back all characters from STDIN, but inverted. + + * Pty.pm (slave): slave now is set to be a controlling tty if possible; + it also remembers it's name now. + + * Makefile.PL: + - on SCO, the slave pts* are in the /dev dir, not /dev/pts + - added test for libutil.h, util.h, pty.h and openpty() + - added symbol TIOCSCTTY + + * Tty.xs: + - some SVR4 only define __SVR4; fixed. + - OSF machines need termio.h for various macros + - AIX doesn't define VOIDSIG; fixed. + - Cygwin can use /dev/ptmx even though that file doesn't exist. + - added openpty() version for FreeBSD and others that have + no good method for creating ptys; untested. + + * Tty.pm: + - moved docu over from Pty.pm to lessen confusion Pty <-> Tty + - added verified systems list + +Change 588 on 2000/09/04 by (Graham Barr) + + Check for /dev/ptmx and /dev/pts instead of testing defined(SVR4) + +Change 587 on 2000/09/04 by (Graham Barr) + + Make ttyname just warn when it is not implemented instead of croak + +Change 586 on 2000/09/04 by (Graham Barr) + + Include for HPUX + +Change 585 on 2000/09/04 by (Graham Barr) + + Makefile.PL + - Fix to how cc is called + +Change 461 on 2000/03/29 by (Graham Barr) + + Release 0.03 + +Change 460 on 2000/03/29 by (Graham Barr) + + General cleanup and added PPD stuff into Makefile.PL + +Change 310 on 1999/05/10 by (Graham Barr) + + - Removed the need for Configure by implementing a test in Makefile.PL + - The existance of constants are now checked at import time, so @EXPORT + had to be renamed to @EXPORT_OK. ie noting is imported by default + + diff --git a/src/IO-Tty-1.17/MANIFEST b/src/IO-Tty-1.17/MANIFEST new file mode 100644 index 0000000000000000000000000000000000000000..4eda42343f9ef1d915543f8bc440199178b15784 --- /dev/null +++ b/src/IO-Tty-1.17/MANIFEST @@ -0,0 +1,13 @@ +ChangeLog +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +Pty.pm +README +t/pty_get_winsize.t +t/test.t +try +Tty.pm +Tty.xs +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/src/IO-Tty-1.17/MANIFEST.SKIP b/src/IO-Tty-1.17/MANIFEST.SKIP new file mode 100644 index 0000000000000000000000000000000000000000..85457e4b6ad601cb9ebb8d31bcfbc103ba382646 --- /dev/null +++ b/src/IO-Tty-1.17/MANIFEST.SKIP @@ -0,0 +1,11 @@ +^.github/ +^.git/.* +^MYMETA.* +^MANIFEST.bak +^.gitignore +^conf/ +^xssubs.c +^Tty/Constant.pm +^Makefile$ +^IO-Tty-\d +^IO-Tty\.ppd$ diff --git a/src/IO-Tty-1.17/META.json b/src/IO-Tty-1.17/META.json new file mode 100644 index 0000000000000000000000000000000000000000..005455c047920f264322370c232060fdde542313 --- /dev/null +++ b/src/IO-Tty-1.17/META.json @@ -0,0 +1,48 @@ +{ + "abstract" : "Pseudo ttys and constants", + "author" : [ + "Roland Giersig " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "IO-Tty", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "Test::More" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/toddr/IO-Tty/issues" + }, + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "https://github.com/toddr/IO-Tty" + } + }, + "version" : "1.17", + "x_serialization_backend" : "JSON::PP version 4.07" +} diff --git a/src/IO-Tty-1.17/META.yml b/src/IO-Tty-1.17/META.yml new file mode 100644 index 0000000000000000000000000000000000000000..fb465a7c5ec0816a02ebd38646afc768a099178e --- /dev/null +++ b/src/IO-Tty-1.17/META.yml @@ -0,0 +1,25 @@ +--- +abstract: 'Pseudo ttys and constants' +author: + - 'Roland Giersig ' +build_requires: + Test::More: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.64, 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-Tty +no_index: + directory: + - t + - inc +resources: + bugtracker: https://github.com/toddr/IO-Tty/issues + license: http://dev.perl.org/licenses/ + repository: https://github.com/toddr/IO-Tty +version: '1.17' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/src/IO-Tty-1.17/Makefile.PL b/src/IO-Tty-1.17/Makefile.PL new file mode 100644 index 0000000000000000000000000000000000000000..6b1b6fab1a57f457d1b71fa5c92e12000d31734e --- /dev/null +++ b/src/IO-Tty-1.17/Makefile.PL @@ -0,0 +1,516 @@ +use ExtUtils::MakeMaker; + +# Signal Testers that this is an unsupported platform. +if ( $^O eq 'MSWin32' ) { + print "This module requires a POSIX compliant system to work. Try cygwin if you need this module on windows\n"; + die "OS unsupported"; +} + +use strict; +use warnings; + +use IO::File; +use File::Spec; +use Config qw(%Config); + +my %cfg; +@cfg{qw(cc ccflags ldflags)} = @Config{qw(cc ccflags ldflags)}; +for my $arg (@ARGV) { + if ( $arg =~ /^(CC|CCFLAGS|LDFLAGS)=(.*)/i ) { + $cfg{lc($1)} = $2; + } +} +if ($ENV{PERL_MM_OPT}) { + # Split on whitespace just like EU::MM + for ( split ' ', $ENV{PERL_MM_OPT} ) { + if ( /^(CC|CCFLAGS|LDFLAGS)=(.*)/i ) { + $cfg{lc($1)} = $2; + } + } +} + +my $flags = "$cfg{ccflags} $cfg{ldflags}"; +$flags =~ s/([^A-Za-z0-9 -_])/\\$1/g; # escape shell-metachars + +$|=1; # to see output immediately +$^W=1; + +my %define; +my @libs; +my $Package_Version = '1.17'; # keep this consistent with Tty.pm +my $Is_Beta = ($Package_Version =~ m/_/); + +open(SUB, ">xssubs.c") or die "open: $!"; + +warn "WARNING: perl versions prior to 5.8 are untested and may have problems.\n" + if $] < 5.008; + +# improve backward-compatibility +@define{qw(-DPL_sv_undef=sv_undef -DPL_dowarn=dowarn)} = (undef, undef) + if $] < 5.004_05; + +print <<_EOT_; +Now let's see what we can find out about your system +(logfiles of failing tests are available in the conf/ dir)... +_EOT_ + +# +# Now some poking around in /dev to see what we can find +# + +@define{qw(-DHAVE_CYGWIN -DHAVE_DEV_PTMX)} = (undef, undef) + if ($^O =~ m/cygwin/i); + +$define{'-DHAVE_DEV_PTMX'} = undef + if (-c '/dev/ptmx'); + +$define{'-DHAVE_DEV_PTYM_CLONE'} = undef + if (-c '/dev/ptym/clone'); + +$define{'-DHAVE_DEV_PTC'} = undef + if (-c "/dev/ptc"); + +$define{'-DHAVE_DEV_PTMX_BSD'} = undef + if (-c "/dev/ptmx_bsd"); + +if (-d "/dev/ptym" and -d "/dev/pty") { + $define{'-DHAVE_DEV_PTYM'} = undef; + +} + + + + +# config tests go to a separate dir +unless( mkdir 'conf', 0777 ) { + my $e = $!; + die "mkdir: $e" unless -d 'conf'; +} + +use Cwd qw(getcwd); +my $dir = getcwd; +chdir('conf') or die "chdir: $!"; + +open(TST,">compilerok.c") or die "open: $!"; +print TST <<'ESQ'; +int main () { return 0; } +ESQ +close(TST); + +if (system("$cfg{'cc'} $flags compilerok.c > compilerok.log 2>&1")) { + die <<"__EOT__"; + +ERROR: cannot run the configured compiler '$cfg{'cc'}' +(see conf/compilerok.log). Suggestions: +1) The compiler '$cfg{'cc'}' is not in your PATH. Add it + to the PATH and try again. OR +2) The compiler isn't installed on your system. Install it. OR +3) You only have a different compiler installed (e.g. 'gcc'). + Either fix the compiler config in the perl Config.pm + or install a perl that was built with the right compiler + (you could build perl yourself with the available compiler). + +Note: this is a system-administration issue, please ask your local +admin for help. Thank you. + +__EOT__ +} + +unlink qw(compilerok.c compilerok.log); + +# checking for various functions + +my %funcs = (ttyname => "", + openpty => "-lutil", + _getpty => "", + strlcpy => "", + sigaction => "", + grantpt => "", + unlockpt => "", + getpt => "", + posix_openpt => "", + ptsname => "", + ptsname_r => "", + ); + +foreach my $f (sort keys %funcs) { + open(TST,">functest_$f.c") or die "open: $!"; + print TST <<"ESQ"; +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char \$ac_func (); below. */ +#include +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $f (); +char (*f) (); + +#ifdef F77_DUMMY_MAIN +# ifdef __cplusplus + extern "C" +# endif + int F77_DUMMY_MAIN() { return 1; } +#endif +int +main () +{ +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$f) || defined (__stub___$f) +choke me +#else +f = $f (); +#endif + + ; + return 0; +} +ESQ + + close(TST); + print "Looking for $f()" . "." x (13-length($f)) . " "; + if (system("$cfg{'cc'} $flags $funcs{$f} functest_$f.c > functest_$f.log 2>&1")) { + print "not found.\n"; + } else { + $define{"-DHAVE_\U$f"} = undef; + push @libs, $funcs{$f} if $funcs{$f}; + print "FOUND.\n"; + unlink "functest_$f.c", "functest_$f.log" ; + } +} + +# find various headerfiles + +my @headers = qw(termios.h termio.h libutil.h util.h pty.h + sys/stropts.h sys/ptyio.h sys/pty.h); +my %headers; + +foreach my $h (sort @headers) { + my $def = $h; + $def =~ s/\W/_/g; + open(TST,">headtest_$def.c") or die "open: $!"; + print TST <<"ESQ"; +#include +#include <$h> +int main () { return 0; } +ESQ + close(TST); + print "Looking for $h" . "." x (15-length($h)) . " "; + if(system("$cfg{'cc'} $flags headtest_$def.c > headtest_$def.log 2>&1")) { + print "not found.\n" + } + else { + $headers{$h} = undef; + $define{"-DHAVE_\U$def"} = $h; + if ( $h eq 'util.h' ) { + # Jump through hoops due to a header clash collision with perl + # The following is highly unportable. + + # First, we need to figure out where the C compiler is looking + # for includes. + my $raw_cc_output = qx($cfg{'cc'} $flags -E -Wp,-v -xc /dev/null 2>&1); + my @cc_output = split /\n+/, $raw_cc_output; + my @inc_paths; + foreach my $maybe_inc_path ( @cc_output ) { + next unless $maybe_inc_path =~ /\A\s+/; + my (undef, $inc_path) = split /\s+/, $maybe_inc_path, 3; + push @inc_paths, $inc_path; + } + + # With the list of include directories, try to find util.h + foreach my $inc_path ( @inc_paths ) { + my $abs_header_path = File::Spec->catfile($inc_path, 'util.h'); + next unless -e $abs_header_path; + # Bingo! Now we need to let the C compiler know, so that our XS + # file will include it. + # Again massively non-portable -- we ideally should be using something + # smart to quote the value. + $define{qq<-DUTIL_H_ABS_PATH=\\"$abs_header_path\\">} = $h if $abs_header_path; + last; + } + } + print "FOUND.\n"; + unlink "headtest_$def.c", "headtest_$def.log"; + } +} + +# now write xssubs + +print SUB qq{sv_setpv(config, "@{[sort keys %define]}");\n}; + +my @ttsyms = qw(B0 B110 B115200 B1200 B134 B150 B153600 B1800 B19200 + B200 B230400 B2400 B300 B307200 B38400 B460800 B4800 B50 + B57600 B600 B75 B76800 B9600 BRKINT BS0 BS1 BSDLY CBAUD + CBAUDEXT CBRK CCTS_OFLOW CDEL CDSUSP CEOF CEOL CEOL2 CEOT + CERASE CESC CFLUSH CIBAUD CIBAUDEXT CINTR CKILL CLNEXT + CLOCAL CNSWTCH CNUL CQUIT CR0 CR1 CR2 CR3 CRDLY CREAD + CRPRNT CRTSCTS CRTSXOFF CRTS_IFLOW CS5 CS6 CS7 CS8 CSIZE + CSTART CSTOP CSTOPB CSUSP CSWTCH CWERASE DEFECHO DIOC + DIOCGETP DIOCSETP DOSMODE ECHO ECHOCTL ECHOE ECHOK ECHOKE + ECHONL ECHOPRT EXTA EXTB FF0 FF1 FFDLY FIORDCHK FLUSHO + HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR IMAXBEL + INLCR INPCK ISIG ISTRIP IUCLC IXANY IXOFF IXON KBENABLED + LDCHG LDCLOSE LDDMAP LDEMAP LDGETT LDGMAP LDIOC LDNMAP + LDOPEN LDSETT LDSMAP LOBLK NCCS NL0 NL1 NLDLY NOFLSH OCRNL + OFDEL OFILL OLCUC ONLCR ONLRET ONOCR OPOST PAGEOUT PARENB + PAREXT PARMRK PARODD PENDIN RCV1EN RTS_TOG TAB0 TAB1 TAB2 + TAB3 TABDLY TCDSET TCFLSH TCGETA TCGETS TCIFLUSH TCIOFF + TCIOFLUSH TCION TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH + TCSANOW TCSBRK TCSETA TCSETAF TCSETAW TCSETCTTY TCSETS + TCSETSF TCSETSW TCXONC TERM_D40 TERM_D42 TERM_H45 + TERM_NONE TERM_TEC TERM_TEX TERM_V10 TERM_V61 TIOCCBRK + TIOCCDTR TIOCCONS TIOCEXCL TIOCFLUSH TIOCGETD TIOCGETC + TIOCGETP TIOCGLTC TIOCSETC TIOCSETN TIOCSETP TIOCSLTC + TIOCGPGRP TIOCGSID TIOCGSOFTCAR TIOCGWINSZ TIOCHPCL + TIOCKBOF TIOCKBON TIOCLBIC TIOCLBIS TIOCLGET TIOCLSET + TIOCMBIC TIOCMBIS TIOCMGET TIOCMSET TIOCM_CAR TIOCM_CD + TIOCM_CTS TIOCM_DSR TIOCM_DTR TIOCM_LE TIOCM_RI TIOCM_RNG + TIOCM_RTS TIOCM_SR TIOCM_ST TIOCNOTTY TIOCNXCL TIOCOUTQ + TIOCREMOTE TIOCSBRK TIOCSCTTY TIOCSDTR TIOCSETD TIOCSIGNAL + TIOCSPGRP TIOCSSID TIOCSSOFTCAR TIOCSTART TIOCSTI TIOCSTOP + TIOCSWINSZ TM_ANL TM_CECHO TM_CINVIS TM_LCF TM_NONE TM_SET + TM_SNL TOSTOP VCEOF VCEOL VDISCARD VDSUSP VEOF VEOL VEOL2 + VERASE VINTR VKILL VLNEXT VMIN VQUIT VREPRINT VSTART VSTOP + VSUSP VSWTCH VT0 VT1 VTDLY VTIME VWERASE WRAP XCASE XCLUDE + XMT1EN XTABS); + +print <<_EOT_; +Checking which symbols compile OK... +(sorry for the tedious check, but some systems have not too clean + header files, to say the least; '+' means OK, '-' means not defined + and '*' has compile problems...) +_EOT_ + +my %badsyms; +my %ttsyms_exist; + +foreach my $s (sort @ttsyms) { + $ttsyms_exist{$s} = undef; + open(TST,">ttsymtest_$s.c") or die "open >ttsymtest_$s.c: $!"; + print TST "#include \n"; + foreach my $h (@headers) { + print TST "#include <$h>\n" if exists $headers{$h}; + } + print TST <<"__EOT__"; +#ifdef $s +int main () { int x; x = (int)$s; return 0; } +#else +#line 29999 +choke me badly on line 29999 +#endif +__EOT__ + close(TST); + + if (system("$cfg{'cc'} $flags @{[keys %define]} ttsymtest_$s.c >ttsymtest_$s.log 2>&1")) { + print SUB qq{newCONSTSUB(stash, "$s", newSV(0));\n}; + # now check if the symbol is defined (should have an error message + # for line 29999 in the logfile) + open(CCOUT, "ttsymtest_$s.log") or die "open ttsymtest_$s.log: $!"; + if (grep {m/29999/} ()) { + # symbol not defined + delete $ttsyms_exist{$s}; + print "-$s "; + unlink "ttsymtest_$s.c", "ttsymtest_$s.log"; + } else { + # was defined, but didn't compile + $badsyms{$s} = undef; + print "*$s "; + } + close CCOUT; + } + else { + print "+$s "; + print SUB qq{newCONSTSUB(stash, "$s", newSViv($s));\n}; + unlink "ttsymtest_$s.c", "ttsymtest_$s.log"; + } +} + +close(SUB); +print "\n\n"; + +# now back to Makefile dir +chdir($dir) or die "chdir: $!"; + +my $all_ok = 1; +foreach my $check + ( + { + defines => [qw"-DHAVE_PTSNAME -DHAVE_PTSNAME_R"], + msg => "WARNING! Neither ptsname() nor ptsname_r() could be found,\n so we cannot use a high-level interface like openpty().\n", + }, + { + defines => [qw"-DHAVE_DEV_PTMX -DHAVE_DEV_PTYM_CLONE -DHAVE_DEV_PTC -DHAVE_DEV_PTMX_BSD -DHAVE__GETPTY -DHAVE_OPENPTY -DHAVE_GETPT -DHAVE_POSIX_OPENPT"], + msg => "No high-level lib or clone device has been found, we will use BSD-style ptys.\n", + }, + ) { + my $any = 0; + foreach my $x (@{$check->{defines}}) { + $any = 1 if exists $define{$x}; + } + if (not $any) { + print $check->{msg}; + $all_ok = 0; + } + } + +my %used_syms = map {($_, undef)} + qw(TIOCSCTTY TCSETCTTY TIOCNOTTY TIOCGWINSZ TIOCSWINSZ); +foreach my $s (sort keys %badsyms) { + if (exists $used_syms{$s}) { + print "WARNING! $s is used by Pty.pm but didn't compile. This may mean reduced functionality.\n"; + $all_ok = 0; + } else { + print "Warning: $s has compile problems, it's thus not available (but it's not used by Pty.pm, so that's OK). See conf/ttsymtest_$s.log for details.\n"; + } +} + +print ">>> Configuration looks good! <<<\n\n" if $all_ok; +print <<'_EOT_' if keys %badsyms; +(If you need those missing symbols, check your header files where those +are declared. I'm expecting them to be found in either termio.h or +termios.h (and their #include hierarchy), but on some systems there +are structs required that can be found in asm/*.h or linux/*.h. You +can try to add these to @headers and see if that helps. Sorry, but +the fault really lies with your system vendor.) + +_EOT_ + +print "Writing IO::Tty::Constant.pm...\n"; +unless( mkdir 'Tty', 0777 ) { + my $e = $!; + die "mkdir: $e" unless -d 'Tty'; +} +open (POD, ">Tty/Constant.pm") or die "open: $!"; +print POD <<"_EOT_"; + +package IO::Tty::Constant; + +our \$VERSION = '$Package_Version'; + +use vars qw(\@ISA \@EXPORT_OK); +require Exporter; + +\@ISA = qw(Exporter); +\@EXPORT_OK = qw(@ttsyms); + +__END__ + +=head1 NAME + +IO::Tty::Constant - Terminal Constants (autogenerated) + +=head1 SYNOPSIS + + use IO::Tty::Constant qw(TIOCNOTTY); + ... + +=head1 DESCRIPTION + +This package defines constants usually found in or + (and their #include hierarchy). Find below an +autogenerated alphabetic list of all known constants and whether they +are defined on your system (prefixed with '+') and have compilation +problems ('o'). Undefined or problematic constants are set to 'undef'. + +=head1 DEFINED CONSTANTS + +=over 4 + +_EOT_ + +foreach my $s (@ttsyms) { + if (exists $badsyms{$s}) { + print POD "=item *\n\n"; + } elsif (exists $ttsyms_exist{$s}) { + print POD "=item +\n\n"; + } else { + print POD "=item -\n\n"; + } + print POD "$s\n\n"; +} + +print POD <<_EOT_; + +=back + +=head1 FOR MORE INFO SEE + +L + +=cut + +_EOT_ + +close POD; + +print <<'__EOT__' if $Is_Beta; +********************************************************************** +WARNING: this is a BETA version. If it works, good for you, if not, +tell me, about it (including full output of +'perl Makefile.PL; make; make test;') and I'll see what I can do. +********************************************************************** +__EOT__ + +print "DEFINE = @{[sort keys %define]}\n"; + +WriteMakefile1( + 'NAME' => 'IO::Tty', + 'VERSION' => $Package_Version, + 'DEFINE' => join(" ", sort keys %define), + 'LIBS' => join(" ", @libs), + 'clean' => {'FILES' => 'xssubs.c conf Tty.exp_old log'}, + 'realclean' => {'FILES' => 'Tty IO-Tty.ppd'}, + 'AUTHOR' => 'Roland Giersig ', + 'ABSTRACT' => 'Pseudo ttys and constants', + 'LICENSE' => 'perl', + 'BUILD_REQUIRES' => { + 'Test::More' => 0, # For testing + }, + 'META_MERGE' => { + 'resources' => { + license => 'http://dev.perl.org/licenses/', + repository => 'https://github.com/toddr/IO-Tty', + bugtracker => 'https://github.com/toddr/IO-Tty/issues', + }, + }, +); + +sub MY::postamble { + + return '' unless $] >= 5.00503; + +<<'ESQ'; + +dist : ppd + +ESQ +} + + +sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. + my %params=@_; + my $eumm_version=$ExtUtils::MakeMaker::VERSION; + $eumm_version=eval $eumm_version; + die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; + die "License not specified" if not exists $params{LICENSE}; + if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { + #EUMM 6.5502 has problems with BUILD_REQUIRES + $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; + delete $params{BUILD_REQUIRES}; + } + delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; + delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; + delete $params{META_MERGE} if $eumm_version < 6.46; + delete $params{META_ADD} if $eumm_version < 6.46; + delete $params{LICENSE} if $eumm_version < 6.31; + delete $params{AUTHOR} if $] < 5.005; + delete $params{ABSTRACT_FROM} if $] < 5.005; + delete $params{BINARY_LOCATION} if $] < 5.005; + + WriteMakefile(%params); +} + diff --git a/src/IO-Tty-1.17/Pty.pm b/src/IO-Tty-1.17/Pty.pm new file mode 100644 index 0000000000000000000000000000000000000000..f7d5b9486257bbbfb873e4454d32daec67855c1a --- /dev/null +++ b/src/IO-Tty-1.17/Pty.pm @@ -0,0 +1,342 @@ +# Documentation at the __END__ + +package IO::Pty; + +use strict; +use Carp; +use IO::Tty qw(TIOCSCTTY TCSETCTTY TIOCNOTTY); +use IO::File; +require POSIX; + +use vars qw(@ISA $VERSION); + +$VERSION = '1.17'; # keep same as in Tty.pm + +@ISA = qw(IO::Handle); +eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty }; +push @ISA, "IO::Stty" if ( not $@ ); # if IO::Stty is installed + +sub new { + my ($class) = $_[0] || "IO::Pty"; + $class = ref($class) if ref($class); + @_ <= 1 or croak 'usage: new $class'; + + my ( $ptyfd, $ttyfd, $ttyname ) = pty_allocate(); + + croak "Cannot open a pty" if not defined $ptyfd; + + my $pty = $class->SUPER::new_from_fd( $ptyfd, "r+" ); + croak "Cannot create a new $class from fd $ptyfd: $!" if not $pty; + $pty->autoflush(1); + bless $pty => $class; + + my $slave = IO::Tty->new_from_fd( $ttyfd, "r+" ); + croak "Cannot create a new IO::Tty from fd $ttyfd: $!" if not $slave; + $slave->autoflush(1); + + ${*$pty}{'io_pty_slave'} = $slave; + ${*$pty}{'io_pty_ttyname'} = $ttyname; + ${*$slave}{'io_tty_ttyname'} = $ttyname; + + return $pty; +} + +sub ttyname { + @_ == 1 or croak 'usage: $pty->ttyname();'; + my $pty = shift; + ${*$pty}{'io_pty_ttyname'}; +} + +sub close_slave { + @_ == 1 or croak 'usage: $pty->close_slave();'; + + my $master = shift; + + if ( exists ${*$master}{'io_pty_slave'} ) { + close ${*$master}{'io_pty_slave'}; + delete ${*$master}{'io_pty_slave'}; + } +} + +sub slave { + @_ == 1 or croak 'usage: $pty->slave();'; + + my $master = shift; + + if ( exists ${*$master}{'io_pty_slave'} ) { + return ${*$master}{'io_pty_slave'}; + } + + my $tty = ${*$master}{'io_pty_ttyname'}; + + my $slave = new IO::Tty; + + $slave->open( $tty, O_RDWR | O_NOCTTY ) + || croak "Cannot open slave $tty: $!"; + + return $slave; +} + +sub make_slave_controlling_terminal { + @_ == 1 or croak 'usage: $pty->make_slave_controlling_terminal();'; + + my $self = shift; + local (*DEVTTY); + + # loose controlling terminal explicitly + if ( defined TIOCNOTTY ) { + if ( open( \*DEVTTY, "/dev/tty" ) ) { + ioctl( \*DEVTTY, TIOCNOTTY, 0 ); + close \*DEVTTY; + } + } + + # Create a new 'session', lose controlling terminal. + if ( POSIX::setsid() == -1 ) { + warn "setsid() failed, strange behavior may result: $!\r\n" if $^W; + } + + if ( open( \*DEVTTY, "/dev/tty" ) ) { + warn "Could not disconnect from controlling terminal?!\n" if $^W; + close \*DEVTTY; + } + + # now open slave, this should set it as controlling tty on some systems + my $ttyname = ${*$self}{'io_pty_ttyname'}; + my $slv = new IO::Tty; + $slv->open( $ttyname, O_RDWR ) + or croak "Cannot open slave $ttyname: $!"; + + if ( not exists ${*$self}{'io_pty_slave'} ) { + ${*$self}{'io_pty_slave'} = $slv; + } + else { + $slv->close; + } + + # Acquire a controlling terminal if this doesn't happen automatically + if ( not open( \*DEVTTY, "/dev/tty" ) ) { + if ( defined TIOCSCTTY ) { + if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TIOCSCTTY, 0 ) ) { + warn "warning: TIOCSCTTY failed, slave might not be set as controlling terminal: $!" if $^W; + } + } + elsif ( defined TCSETCTTY ) { + if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TCSETCTTY, 0 ) ) { + warn "warning: TCSETCTTY failed, slave might not be set as controlling terminal: $!" if $^W; + } + } + else { + warn "warning: You have neither TIOCSCTTY nor TCSETCTTY on your system\n" if $^W; + return 0; + } + } + + if ( not open( \*DEVTTY, "/dev/tty" ) ) { + warn "Error: could not connect pty as controlling terminal!\n"; + return undef; + } + else { + close \*DEVTTY; + } + + return 1; +} + +*clone_winsize_from = \&IO::Tty::clone_winsize_from; +*get_winsize = \&IO::Tty::get_winsize; +*set_winsize = \&IO::Tty::set_winsize; +*set_raw = \&IO::Tty::set_raw; + +1; + +__END__ + +=head1 NAME + +IO::Pty - Pseudo TTY object class + +=head1 VERSION + +1.17 + +=head1 SYNOPSIS + + use IO::Pty; + + $pty = new IO::Pty; + + $slave = $pty->slave; + + foreach $val (1..10) { + print $pty "$val\n"; + $_ = <$slave>; + print "$_"; + } + + close($slave); + + +=head1 DESCRIPTION + +C provides an interface to allow the creation of a pseudo tty. + +C inherits from C and so provide all the methods +defined by the C package. + +Please note that pty creation is very system-dependent. If you have +problems, see L for help. + + +=head1 CONSTRUCTOR + +=over 3 + +=item new + +The C constructor takes no arguments and returns a new file +object which is the master side of the pseudo tty. + +=back + +=head1 METHODS + +=over 4 + +=item ttyname() + +Returns the name of the slave pseudo tty. On UNIX machines this will +be the pathname of the device. Use this name for informational +purpose only, to get a slave filehandle, use slave(). + +=item slave() + +The C method will return the slave filehandle of the given +master pty, opening it anew if necessary. If IO::Stty is installed, +you can then call C<$slave-Estty()> to modify the terminal settings. + +=item close_slave() + +The slave filehandle will be closed and destroyed. This is necessary +in the parent after forking to get rid of the open filehandle, +otherwise the parent will not notice if the child exits. Subsequent +calls of C will return a newly opened slave filehandle. + +=item make_slave_controlling_terminal() + +This will set the slave filehandle as the controlling terminal of the +current process, which will become a session leader, so this should +only be called by a child process after a fork(), e.g. in the callback +to C (see L). See the C script +(also C) for an example how to correctly spawn a subprocess. + +=item set_raw() + +Will set the pty to raw. Note that this is a one-way operation, you +need IO::Stty to set the terminal settings to anything else. + +On some systems, the master pty is not a tty. This method checks for +that and returns success anyway on such systems. Note that this +method must be called on the slave, and probably should be called on +the master, just to be sure, i.e. + + $pty->slave->set_raw(); + $pty->set_raw(); + + +=item clone_winsize_from(\*FH) + +Gets the terminal size from filehandle FH (which must be a terminal) +and transfers it to the pty. Returns true on success and undef on +failure. Note that this must be called upon the I, i.e. + + $pty->slave->clone_winsize_from(\*STDIN); + +On some systems, the master pty also isatty. I actually have no +idea if setting terminal sizes there is passed through to the slave, +so if this method is called for a master that is not a tty, it +silently returns OK. + +See the C script for example code how to propagate SIGWINCH. + +=item get_winsize() + +Returns the terminal size, in a 4-element list. + + ($row, $col, $xpixel, $ypixel) = $tty->get_winsize() + +=item set_winsize($row, $col, $xpixel, $ypixel) + +Sets the terminal size. If not specified, C<$xpixel> and C<$ypixel> are set to +0. As with C, this must be called upon the I. + +=back + + +=head1 SEE ALSO + +L, L, L, L, L + + +=head1 MAILING LISTS + +As this module is mainly used by Expect, support for it is available +via the two Expect mailing lists, expectperl-announce and +expectperl-discuss, at + + http://lists.sourceforge.net/lists/listinfo/expectperl-announce + +and + + http://lists.sourceforge.net/lists/listinfo/expectperl-discuss + + +=head1 AUTHORS + +Originally by Graham Barr EFE, based on the +Ptty module by Nick Ing-Simmons EFE. + +Now maintained and heavily rewritten by Roland Giersig +EFE. + +Contains copyrighted stuff from openssh v3.0p1, authored by +Tatu Ylonen , Markus Friedl and Todd C. Miller +. + + +=head1 COPYRIGHT + +Now all code is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Nevertheless the above AUTHORS retain their copyrights to the various +parts and want to receive credit if their source code is used. +See the source for details. + + +=head1 DISCLAIMER + +THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +In other words: Use at your own risk. Provided as is. Your mileage +may vary. Read the source, Luke! + +And finally, just to be sure: + +Any Use of This Product, in Any Manner Whatsoever, Will Increase the +Amount of Disorder in the Universe. Although No Liability Is Implied +Herein, the Consumer Is Warned That This Process Will Ultimately Lead +to the Heat Death of the Universe. + +=cut + diff --git a/src/IO-Tty-1.17/README b/src/IO-Tty-1.17/README new file mode 100644 index 0000000000000000000000000000000000000000..ba32843412e812b5059a49f79655f79f28ff6e7f --- /dev/null +++ b/src/IO-Tty-1.17/README @@ -0,0 +1,162 @@ +NAME + IO::Tty - Low-level allocate a pseudo-Tty, import constants. + +VERSION + 1.17 + +SYNOPSIS + use IO::Tty qw(TIOCNOTTY); + ... + # use only to import constants, see IO::Pty to create ptys. + +DESCRIPTION + "IO::Tty" is used internally by "IO::Pty" to create a pseudo-tty. You + wouldn't want to use it directly except to import constants, use + "IO::Pty". For a list of importable constants, see IO::Tty::Constant. + + Windows is now supported, but ONLY under the Cygwin environment, see + . + + Please note that pty creation is very system-dependend. From my + experience, any modern POSIX system should be fine. Find below a list of + systems that "IO::Tty" should work on. A more detailed table (which is + slowly getting out-of-date) is available from the project pages document + manager at SourceForge . + + If you have problems on your system and your system is listed in the + "verified" list, you probably have some non-standard setup, e.g. you + compiled your Linux-kernel yourself and disabled ptys (bummer!). Please + ask your friendly sysadmin for help. + + If your system is not listed, unpack the latest version of "IO::Tty", do + a 'perl Makefile.PL; make; make test; uname -a' and send me + (RGiersig@cpan.org) the results and I'll see what I can deduce from + that. There are chances that it will work right out-of-the-box... + + If it's working on your system, please send me a short note with details + (version number, distribution, etc. 'uname -a' and 'perl -V' is a good + start; also, the output from "perl Makefile.PL" contains a lot of + interesting info, so please include that as well) so I can get an + overview. Thanks! + +VERIFIED SYSTEMS, KNOWN ISSUES + This is a list of systems that "IO::Tty" seems to work on ('make test' + passes) with comments about "features": + + * AIX 4.3 + + Returns EIO instead of EOF when the slave is closed. Benign. + + * AIX 5.x + + * FreeBSD 4.4 + + EOF on the slave tty is not reported back to the master. + + * OpenBSD 2.8 + + The ioctl TIOCSCTTY sometimes fails. This is also known in + Tcl/Expect, see http://expect.nist.gov/FAQ.html + + EOF on the slave tty is not reported back to the master. + + * Darwin 7.9.0 + + * HPUX 10.20 & 11.00 + + EOF on the slave tty is not reported back to the master. + + * IRIX 6.5 + + * Linux 2.2.x & 2.4.x + + Returns EIO instead of EOF when the slave is closed. Benign. + + * OSF 4.0 + + EOF on the slave tty is not reported back to the master. + + * Solaris 8, 2.7, 2.6 + + Has the "feature" of returning EOF just once?! + + EOF on the slave tty is not reported back to the master. + + * Windows NT/2k/XP (under Cygwin) + + When you send (print) a too long line (>160 chars) to a non-raw pty, + the call just hangs forever and even alarm() cannot get you out. + Don't complain to me... + + EOF on the slave tty is not reported back to the master. + + * z/OS + + The following systems have not been verified yet for this version, but a + previous version worked on them: + + * SCO Unix + + * NetBSD + + probably the same as the other *BSDs... + + If you have additions to these lists, please mail them to + . + +SEE ALSO + IO::Pty, IO::Tty::Constant + +MAILING LISTS + As this module is mainly used by Expect, support for it is available via + the two Expect mailing lists, expectperl-announce and + expectperl-discuss, at + + http://lists.sourceforge.net/lists/listinfo/expectperl-announce + + and + + http://lists.sourceforge.net/lists/listinfo/expectperl-discuss + +AUTHORS + Originally by Graham Barr , based on the Ptty module by + Nick Ing-Simmons . + + Now maintained and heavily rewritten by Roland Giersig + . + + Contains copyrighted stuff from openssh v3.0p1, authored by Tatu Ylonen + , Markus Friedl and Todd C. Miller + . I also got a lot of inspiration from the + pty code in Xemacs. + +COPYRIGHT + Now all code is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + + Nevertheless the above AUTHORS retain their copyrights to the various + parts and want to receive credit if their source code is used. See the + source for details. + +DISCLAIMER + THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED + WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN + NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF + USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + In other words: Use at your own risk. Provided as is. Your mileage may + vary. Read the source, Luke! + + And finally, just to be sure: + + Any Use of This Product, in Any Manner Whatsoever, Will Increase the + Amount of Disorder in the Universe. Although No Liability Is Implied + Herein, the Consumer Is Warned That This Process Will Ultimately Lead to + the Heat Death of the Universe. + diff --git a/src/IO-Tty-1.17/Tty.pm b/src/IO-Tty-1.17/Tty.pm new file mode 100755 index 0000000000000000000000000000000000000000..1265b354dac123a02a9875f69870baed4bb5ed9b --- /dev/null +++ b/src/IO-Tty-1.17/Tty.pm @@ -0,0 +1,308 @@ +# Documentation at the __END__ +# -*-cperl-*- + +package IO::Tty; + +use strict; +use warnings; +use IO::Handle; +use IO::File; +use IO::Tty::Constant; +use Carp; + +require POSIX; +require DynaLoader; + +use vars qw(@ISA $VERSION $XS_VERSION $CONFIG $DEBUG); + +$VERSION = '1.17'; +$XS_VERSION = "1.17"; +@ISA = qw(IO::Handle); + +eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty }; +push @ISA, "IO::Stty" if ( not $@ ); # if IO::Stty is installed + +BOOT_XS: { + # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO + require DynaLoader; + + # DynaLoader calls dl_load_flags as a static method. + *dl_load_flags = DynaLoader->can('dl_load_flags'); + + do { + defined(&bootstrap) + ? \&bootstrap + : \&DynaLoader::bootstrap; + } + ->(__PACKAGE__); +} + +sub import { + IO::Tty::Constant->export_to_level( 1, @_ ); +} + +sub open { + my ( $tty, $dev, $mode ) = @_; + + IO::File::open( $tty, $dev, $mode ) + or return undef; + + $tty->autoflush; + + 1; +} + +sub clone_winsize_from { + my ( $self, $fh ) = @_; + croak "Given filehandle is not a tty in clone_winsize_from, called" + if not POSIX::isatty($fh); + return 1 if not POSIX::isatty($self); # ignored for master ptys + my $winsize = " " x 1024; # preallocate memory for older perl versions + $winsize = ''; # But leave the SV as empty + ioctl( $fh, &IO::Tty::Constant::TIOCGWINSZ, $winsize ) + and ioctl( $self, &IO::Tty::Constant::TIOCSWINSZ, $winsize ) + and return 1; + warn "clone_winsize_from: error: $!" if $^W; + return undef; +} + +# ioctl() doesn't tell us how long the structure is, so we'll have to trim it +# after TIOCGWINSZ +my $SIZEOF_WINSIZE = length IO::Tty::pack_winsize( 0, 0, 0, 0 ); + +sub get_winsize { + my $self = shift; + my $winsize = " " x 1024; # preallocate memory + ioctl( $self, IO::Tty::Constant::TIOCGWINSZ(), $winsize ) + or croak "Cannot TIOCGWINSZ - $!"; + substr( $winsize, $SIZEOF_WINSIZE ) = ""; + return IO::Tty::unpack_winsize($winsize); +} + +sub set_winsize { + my $self = shift; + my $winsize = IO::Tty::pack_winsize(@_); + ioctl( $self, IO::Tty::Constant::TIOCSWINSZ(), $winsize ) + or croak "Cannot TIOCSWINSZ - $!"; +} + +sub set_raw($) { + require POSIX; + my $self = shift; + return 1 if not POSIX::isatty($self); + my $ttyno = fileno($self); + my $termios = new POSIX::Termios; + unless ($termios) { + warn "set_raw: new POSIX::Termios failed: $!"; + return undef; + } + unless ( $termios->getattr($ttyno) ) { + warn "set_raw: getattr($ttyno) failed: $!"; + return undef; + } + $termios->setiflag(0); + $termios->setoflag(0); + $termios->setlflag(0); + $termios->setcc( &POSIX::VMIN, 1 ); + $termios->setcc( &POSIX::VTIME, 0 ); + unless ( $termios->setattr( $ttyno, &POSIX::TCSANOW ) ) { + warn "set_raw: setattr($ttyno) failed: $!"; + return undef; + } + return 1; +} + +1; + +__END__ + +=head1 NAME + +IO::Tty - Low-level allocate a pseudo-Tty, import constants. + +=head1 VERSION + +1.17 + +=head1 SYNOPSIS + + use IO::Tty qw(TIOCNOTTY); + ... + # use only to import constants, see IO::Pty to create ptys. + +=head1 DESCRIPTION + +C is used internally by C to create a pseudo-tty. +You wouldn't want to use it directly except to import constants, use +C. For a list of importable constants, see +L. + +Windows is now supported, but ONLY under the Cygwin +environment, see L. + +Please note that pty creation is very system-dependend. From my +experience, any modern POSIX system should be fine. Find below a list +of systems that C should work on. A more detailed table +(which is slowly getting out-of-date) is available from the project +pages document manager at SourceForge +L. + +If you have problems on your system and your system is listed in the +"verified" list, you probably have some non-standard setup, e.g. you +compiled your Linux-kernel yourself and disabled ptys (bummer!). +Please ask your friendly sysadmin for help. + +If your system is not listed, unpack the latest version of C, +do a C<'perl Makefile.PL; make; make test; uname -a'> and send me +(F) the results and I'll see what I can deduce from +that. There are chances that it will work right out-of-the-box... + +If it's working on your system, please send me a short note with +details (version number, distribution, etc. 'uname -a' and 'perl -V' +is a good start; also, the output from "perl Makefile.PL" contains a +lot of interesting info, so please include that as well) so I can get +an overview. Thanks! + + +=head1 VERIFIED SYSTEMS, KNOWN ISSUES + +This is a list of systems that C seems to work on ('make +test' passes) with comments about "features": + +=over 4 + +=item * AIX 4.3 + +Returns EIO instead of EOF when the slave is closed. Benign. + +=item * AIX 5.x + +=item * FreeBSD 4.4 + +EOF on the slave tty is not reported back to the master. + +=item * OpenBSD 2.8 + +The ioctl TIOCSCTTY sometimes fails. This is also known in +Tcl/Expect, see http://expect.nist.gov/FAQ.html + +EOF on the slave tty is not reported back to the master. + +=item * Darwin 7.9.0 + +=item * HPUX 10.20 & 11.00 + +EOF on the slave tty is not reported back to the master. + +=item * IRIX 6.5 + +=item * Linux 2.2.x & 2.4.x + +Returns EIO instead of EOF when the slave is closed. Benign. + +=item * OSF 4.0 + +EOF on the slave tty is not reported back to the master. + +=item * Solaris 8, 2.7, 2.6 + +Has the "feature" of returning EOF just once?! + +EOF on the slave tty is not reported back to the master. + +=item * Windows NT/2k/XP (under Cygwin) + +When you send (print) a too long line (>160 chars) to a non-raw pty, +the call just hangs forever and even alarm() cannot get you out. +Don't complain to me... + +EOF on the slave tty is not reported back to the master. + +=item * z/OS + +=back + +The following systems have not been verified yet for this version, but +a previous version worked on them: + +=over 4 + +=item * SCO Unix + +=item * NetBSD + +probably the same as the other *BSDs... + +=back + +If you have additions to these lists, please mail them to +EFE. + + +=head1 SEE ALSO + +L, L + + +=head1 MAILING LISTS + +As this module is mainly used by Expect, support for it is available +via the two Expect mailing lists, expectperl-announce and +expectperl-discuss, at + + http://lists.sourceforge.net/lists/listinfo/expectperl-announce + +and + + http://lists.sourceforge.net/lists/listinfo/expectperl-discuss + + +=head1 AUTHORS + +Originally by Graham Barr EFE, based on the +Ptty module by Nick Ing-Simmons EFE. + +Now maintained and heavily rewritten by Roland Giersig +EFE. + +Contains copyrighted stuff from openssh v3.0p1, authored by Tatu +Ylonen , Markus Friedl and Todd C. Miller +. I also got a lot of inspiration from +the pty code in Xemacs. + + +=head1 COPYRIGHT + +Now all code is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +Nevertheless the above AUTHORS retain their copyrights to the various +parts and want to receive credit if their source code is used. +See the source for details. + + +=head1 DISCLAIMER + +THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +In other words: Use at your own risk. Provided as is. Your mileage +may vary. Read the source, Luke! + +And finally, just to be sure: + +Any Use of This Product, in Any Manner Whatsoever, Will Increase the +Amount of Disorder in the Universe. Although No Liability Is Implied +Herein, the Consumer Is Warned That This Process Will Ultimately Lead +to the Heat Death of the Universe. + +=cut diff --git a/src/IO-Tty-1.17/Tty.xs b/src/IO-Tty-1.17/Tty.xs new file mode 100644 index 0000000000000000000000000000000000000000..aa638f4a849e2f4f050585846b99c4944c06eb52 --- /dev/null +++ b/src/IO-Tty-1.17/Tty.xs @@ -0,0 +1,887 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define PTY_DEBUG 1 + +#ifdef PTY_DEBUG +static int print_debug; +#endif + +#ifdef PerlIO +typedef int SysRet; +typedef PerlIO * InOutStream; +#else +# define PERLIO_IS_STDIO 1 +# define PerlIO_fileno fileno +typedef int SysRet; +typedef FILE * InOutStream; +#endif + +#include "patchlevel.h" + +#if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22)) + /* before 5.003_22 */ +# define MY_start_subparse(fmt,flags) start_subparse() +#else +# if (PATCHLEVEL == 3) && (SUBVERSION == 22) + /* 5.003_22 */ +# define MY_start_subparse(fmt,flags) start_subparse(flags) +# else + /* 5.003_23 onwards */ +# define MY_start_subparse(fmt,flags) start_subparse(fmt,flags) +# endif +#endif + +/* + * The following pty-allocation code was heavily inspired by its + * counterparts in openssh 3.0p1 and Xemacs 21.4.5 but is a complete + * rewrite by me, Roland Giersig . + * + * Nevertheless my references to Tatu Ylonen + * and the Xemacs development team for their inspiring code. + * + * mysignal and strlcpy were borrowed from openssh and have their + * copyright messages attached. + */ + +#include +#include +#include +#include +#include +#include +#include + +#ifdef HAVE_LIBUTIL_H +# include +#endif /* HAVE_UTIL_H */ + +#ifdef HAVE_UTIL_H +# ifdef UTIL_H_ABS_PATH +# include UTIL_H_ABS_PATH +# elif ((PATCHLEVEL < 19) && (SUBVERSION < 4)) +# include +# endif +#endif /* HAVE_UTIL_H */ + +#ifdef HAVE_PTY_H +# include +#endif + +#ifdef HAVE_SYS_PTY_H +# include +#endif + +#ifdef HAVE_SYS_PTYIO_H +# include +#endif + +#if defined(HAVE_DEV_PTMX) && defined(HAVE_SYS_STROPTS_H) +# include +#endif + +#ifdef HAVE_TERMIOS_H +#include +#endif + +#ifdef HAVE_TERMIO_H +#include +#endif + +#ifndef O_NOCTTY +#define O_NOCTTY 0 +#endif + + +/* from $OpenBSD: misc.c,v 1.12 2001/06/26 17:27:24 markus Exp $ */ + +/* + * Copyright (c) 2000 Markus Friedl. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include + +typedef void (*mysig_t)(int); + +static mysig_t +mysignal(int sig, mysig_t act) +{ +#ifdef HAVE_SIGACTION + struct sigaction sa, osa; + + if (sigaction(sig, NULL, &osa) == -1) + return (mysig_t) -1; + if (osa.sa_handler != act) { + memset(&sa, 0, sizeof(sa)); + sigemptyset(&sa.sa_mask); + sa.sa_flags = 0; +#if defined(SA_INTERRUPT) + if (sig == SIGALRM) + sa.sa_flags |= SA_INTERRUPT; +#endif + sa.sa_handler = act; + if (sigaction(sig, &sa, NULL) == -1) + return (mysig_t) -1; + } + return (osa.sa_handler); +#else + return (signal(sig, act)); +#endif +} + +/* from $OpenBSD: strlcpy.c,v 1.5 2001/05/13 15:40:16 deraadt Exp $ */ + +/* + * Copyright (c) 1998 Todd C. Miller + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL + * THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#ifndef HAVE_STRLCPY + +/* + * Copy src to string dst of size siz. At most siz-1 characters + * will be copied. Always NUL terminates (unless siz == 0). + * Returns strlen(src); if retval >= siz, truncation occurred. + */ +static size_t +strlcpy(dst, src, siz) + char *dst; + const char *src; + size_t siz; +{ + register char *d = dst; + register const char *s = src; + register size_t n = siz; + + /* Copy as many bytes as will fit */ + if (n != 0 && --n != 0) { + do { + if ((*d++ = *s++) == 0) + break; + } while (--n != 0); + } + + /* Not enough room in dst, add NUL and traverse rest of src */ + if (n == 0) { + if (siz != 0) + *d = '\0'; /* NUL-terminate dst */ + while (*s++) + ; + } + + return(s - src - 1); /* count does not include NUL */ +} + +#endif /* !HAVE_STRLCPY */ + +/* + * Move file descriptor so it doesn't collide with stdin/out/err + */ + +static void +make_safe_fd(int * fd) +{ + if (*fd < 3) { + int newfd; + newfd = fcntl(*fd, F_DUPFD, 3); + if (newfd < 0) { + if (PL_dowarn) + warn("IO::Tty::pty_allocate(nonfatal): tried to move fd %d up but fcntl() said %.100s", *fd, strerror(errno)); + } else { + close (*fd); + *fd = newfd; + } + } +} + +/* + * After having acquired a master pty, try to find out the slave name, + * initialize and open the slave. + */ + +#if defined (HAVE_PTSNAME) +char * ptsname(int); +#endif + +static int +open_slave(int *ptyfd, int *ttyfd, char *namebuf, int namebuflen) +{ + /* + * now do some things that are supposedly healthy for ptys, + * i.e. changing the access mode. + */ +#if defined(HAVE_GRANTPT) || defined(HAVE_UNLOCKPT) + { + mysig_t old_signal; + old_signal = mysignal(SIGCHLD, SIG_DFL); +#if defined(HAVE_GRANTPT) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying grantpt()...\n"); +#endif + if (grantpt(*ptyfd) < 0) { + if (PL_dowarn) + warn("IO::Tty::pty_allocate(nonfatal): grantpt(): %.100s", strerror(errno)); + } + +#endif /* HAVE_GRANTPT */ +#if defined(HAVE_UNLOCKPT) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying unlockpt()...\n"); +#endif + if (unlockpt(*ptyfd) < 0) { + if (PL_dowarn) + warn("IO::Tty::pty_allocate(nonfatal): unlockpt(): %.100s", strerror(errno)); + } +#endif /* HAVE_UNLOCKPT */ + mysignal(SIGCHLD, old_signal); + } +#endif /* HAVE_GRANTPT || HAVE_UNLOCKPT */ + + + /* + * find the slave name, if we don't have it already + */ + +#if defined (HAVE_PTSNAME_R) + if (namebuf[0] == 0) { +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying ptsname_r()...\n"); +#endif + if(ptsname_r(*ptyfd, namebuf, namebuflen)) { + if (PL_dowarn) + warn("IO::Tty::open_slave(nonfatal): ptsname_r(): %.100s", strerror(errno)); + } + } +#endif /* HAVE_PTSNAME_R */ + +#if defined (HAVE_PTSNAME) + if (namebuf[0] == 0) { + char * name; +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying ptsname()...\n"); +#endif + name = ptsname(*ptyfd); + if (name) { + if(strlcpy(namebuf, name, namebuflen) >= namebuflen) { + warn("ERROR: IO::Tty::open_slave: ttyname truncated"); + return 0; + } + } else { + if (PL_dowarn) + warn("IO::Tty::open_slave(nonfatal): ptsname(): %.100s", strerror(errno)); + } + } +#endif /* HAVE_PTSNAME */ + + if (namebuf[0] == 0) + return 0; /* we failed to get the slave name */ + +#if defined (__SVR4) && defined (__sun) + #include + #include + { + uid_t euid = geteuid(); + uid_t uid = getuid(); + + /* root running as another user + * grantpt() has done the wrong thing + */ + if (euid != uid && uid == 0) { +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying seteuid() from %d to %d...\n", + euid, uid); +#endif + if (setuid(uid)) { + warn("ERROR: IO::Tty::open_slave: couldn't seteuid to root: %d", errno); + return 0; + } + if (chown(namebuf, euid, -1)) { + warn("ERROR: IO::Tty::open_slave: couldn't fchown the pty: %d", errno); + return 0; + } + if (seteuid(euid)) { + warn("ERROR: IO::Tty::open_slave: couldn't seteuid back: %d", errno); + return 0; + } + } + } +#endif + + if (*ttyfd >= 0) { + make_safe_fd(ptyfd); + make_safe_fd(ttyfd); + return 1; /* we already have an open slave, so + no more init is needed */ + } + + /* + * Open the slave side. + */ +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying to open %s...\n", namebuf); +#endif + + *ttyfd = open(namebuf, O_RDWR | O_NOCTTY); + if (*ttyfd < 0) { + if (PL_dowarn) + warn("IO::Tty::open_slave(nonfatal): open(%.200s): %.100s", + namebuf, strerror(errno)); + close(*ptyfd); + return 0; /* too bad, couldn't open slave side */ + } + +#if defined (I_PUSH) + /* + * Push appropriate streams modules for Solaris pty(7). + * HP-UX pty(7) doesn't have ttcompat module. + * We simply try to push all relevant modules but warn only on + * those platforms we know these are required. + */ +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying to I_PUSH ptem...\n"); +#endif + if (ioctl(*ttyfd, I_PUSH, "ptem") < 0) +#if defined (__solaris) || defined(__hpux) + if (PL_dowarn) + warn("IO::Tty::pty_allocate: ioctl I_PUSH ptem: %.100s", strerror(errno)) +#endif + ; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying to I_PUSH ldterm...\n"); +#endif + if (ioctl(*ttyfd, I_PUSH, "ldterm") < 0) +#if defined (__solaris) || defined(__hpux) + if (PL_dowarn) + warn("IO::Tty::pty_allocate: ioctl I_PUSH ldterm: %.100s", strerror(errno)) +#endif + ; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying to I_PUSH ttcompat...\n"); +#endif + if (ioctl(*ttyfd, I_PUSH, "ttcompat") < 0) +#if defined (__solaris) + if (PL_dowarn) + warn("IO::Tty::pty_allocate: ioctl I_PUSH ttcompat: %.100s", strerror(errno)) +#endif + ; +#endif /* I_PUSH */ + + /* finally we make sure the filedescriptors are > 2 to avoid + problems with stdin/out/err. This can happen if the user + closes one of them before allocating a pty and leads to nasty + side-effects, so we take a proactive stance here. Normally I + would say "Those who mess with stdin/out/err shall bear the + consequences to the fullest" but hey, I'm a nice guy... ;O) */ + + make_safe_fd(ptyfd); + make_safe_fd(ttyfd); + + return 1; +} + +/* + * Allocates and opens a pty. Returns 0 if no pty could be allocated, or + * nonzero if a pty was successfully allocated. On success, open file + * descriptors for the pty and tty sides and the name of the tty side are + * returned (the buffer must be able to hold at least 64 characters). + * + * Instead of trying just one method we go through all available + * methods until we get a positive result. + */ + +static int +allocate_pty(int *ptyfd, int *ttyfd, char *namebuf, int namebuflen) +{ + *ptyfd = -1; + *ttyfd = -1; + namebuf[0] = 0; + + /* + * first we try to get a master device + */ + do { /* we use do{}while(0) and break instead of goto */ + +#if defined(HAVE__GETPTY) + /* _getpty(3) for SGI Irix */ + { + char *slave; + mysig_t old_signal; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying _getpty()...\n"); +#endif + /* _getpty spawns a suid prog, so don't ignore SIGCHLD */ + old_signal = mysignal(SIGCHLD, SIG_DFL); + slave = _getpty(ptyfd, O_RDWR, 0622, 0); + mysignal(SIGCHLD, old_signal); + + if (slave != NULL) { + if (strlcpy(namebuf, slave, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + if (open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + close(*ptyfd); + *ptyfd = -1; + } else { + if (PL_dowarn) + warn("pty_allocate(nonfatal): _getpty(): %.100s", strerror(errno)); + *ptyfd = -1; + } + } +#endif + +#if defined(HAVE_PTSNAME) || defined(HAVE_PTSNAME_R) +/* we don't need to try these if we don't have a way to get the pty names */ + +#if defined(HAVE_POSIX_OPENPT) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying posix_openpt()...\n"); +#endif + *ptyfd = posix_openpt(O_RDWR|O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; /* got one */ + if (PL_dowarn) + warn("pty_allocate(nonfatal): posix_openpt(): %.100s", strerror(errno)); +#endif /* defined(HAVE_POSIX_OPENPT) */ + +#if defined(HAVE_GETPT) + /* glibc defines this */ +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying getpt()...\n"); +#endif + *ptyfd = getpt(); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; /* got one */ + if (PL_dowarn) + warn("pty_allocate(nonfatal): getpt(): %.100s", strerror(errno)); +#endif /* defined(HAVE_GETPT) */ + +#if defined(HAVE_OPENPTY) + /* openpty(3) exists in a variety of OS'es, but due to it's + * broken interface (no maxlen to slavename) we'll only use it + * to create the tty/pty pair and rely on ptsname to get the + * name. */ + { + mysig_t old_signal; + int ret; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying openpty()...\n"); +#endif + old_signal = mysignal(SIGCHLD, SIG_DFL); + ret = openpty(ptyfd, ttyfd, NULL, NULL, NULL); + mysignal(SIGCHLD, old_signal); + if (ret >= 0 && *ptyfd >= 0) { + if (open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + } + *ptyfd = -1; + *ttyfd = -1; + if (PL_dowarn) + warn("pty_allocate(nonfatal): openpty(): %.100s", strerror(errno)); + } +#endif /* defined(HAVE_OPENPTY) */ + + /* + * now try various cloning devices + */ + +#if defined(HAVE_DEV_PTMX) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying /dev/ptmx...\n"); +#endif + + *ptyfd = open("/dev/ptmx", O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + if (PL_dowarn) + warn("pty_allocate(nonfatal): open(/dev/ptmx): %.100s", strerror(errno)); +#endif /* HAVE_DEV_PTMX */ + +#if defined(HAVE_DEV_PTYM_CLONE) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying /dev/ptym/clone...\n"); +#endif + + *ptyfd = open("/dev/ptym/clone", O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + if (PL_dowarn) + warn("pty_allocate(nonfatal): open(/dev/ptym/clone): %.100s", strerror(errno)); +#endif /* HAVE_DEV_PTYM_CLONE */ + +#if defined(HAVE_DEV_PTC) + /* AIX-style pty code. */ +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying /dev/ptc...\n"); +#endif + + *ptyfd = open("/dev/ptc", O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + if (PL_dowarn) + warn("pty_allocate(nonfatal): open(/dev/ptc): %.100s", strerror(errno)); +#endif /* HAVE_DEV_PTC */ + +#if defined(HAVE_DEV_PTMX_BSD) +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying /dev/ptmx_bsd...\n"); +#endif + *ptyfd = open("/dev/ptmx_bsd", O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + if (PL_dowarn) + warn("pty_allocate(nonfatal): open(/dev/ptmx_bsd): %.100s", strerror(errno)); +#endif /* HAVE_DEV_PTMX_BSD */ + +#endif /* !defined(HAVE_PTSNAME) && !defined(HAVE_PTSNAME_R) */ + + /* + * we still don't have a pty, so try some oldfashioned stuff, + * looking for a pty/tty pair ourself. + */ + +#if defined(_CRAY) + { + char buf[64]; + int i; + int highpty; + +#ifdef _SC_CRAY_NPTY + highpty = sysconf(_SC_CRAY_NPTY); + if (highpty == -1) + highpty = 128; +#else + highpty = 128; +#endif +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying CRAY /dev/pty/???...\n"); +#endif + for (i = 0; i < highpty; i++) { + sprintf(buf, "/dev/pty/%03d", i); + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd < 0) + continue; + sprintf(buf, "/dev/ttyp%03d", i); + if (strlcpy(namebuf, buf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + break; + } + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + } +#endif + +#if defined(HAVE_DEV_PTYM) + { + /* HPUX */ + char buf[64]; + char tbuf[64]; + int i; + struct stat sb; + const char *ptymajors = "abcefghijklmnopqrstuvwxyz"; + const char *ptyminors = "0123456789abcdef"; + int num_minors = strlen(ptyminors); + int num_ptys = strlen(ptymajors) * num_minors; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying HPUX /dev/ptym/pty[a-ce-z][0-9a-f]...\n"); +#endif + /* try /dev/ptym/pty[a-ce-z][0-9a-f] */ + for (i = 0; i < num_ptys; i++) { + sprintf(buf, "/dev/ptym/pty%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + sprintf(tbuf, "/dev/pty/tty%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + if(stat(buf, &sb)) + break; /* file does not exist, skip rest */ + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + namebuf[0] = 0; + } + if (*ptyfd >= 0) + break; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying HPUX /dev/ptym/pty[a-ce-z][0-9][0-9]...\n"); +#endif + /* now try /dev/ptym/pty[a-ce-z][0-9][0-9] */ + num_minors = 100; + num_ptys = strlen(ptymajors) * num_minors; + for (i = 0; i < num_ptys; i++) { + sprintf(buf, "/dev/ptym/pty%c%02d", + ptymajors[i / num_minors], + i % num_minors); + sprintf(tbuf, "/dev/pty/tty%c%02d", + ptymajors[i / num_minors], i % num_minors); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + + if(stat(buf, &sb)) + break; /* file does not exist, skip rest */ + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + namebuf[0] = 0; + } + if (*ptyfd >= 0) + break; + } +#endif /* HAVE_DEV_PTYM */ + + { + /* BSD-style pty code. */ + char buf[64]; + char tbuf[64]; + int i; + const char *ptymajors = "pqrstuvwxyzabcdefghijklmnoABCDEFGHIJKLMNOPQRSTUVWXYZ"; + const char *ptyminors = "0123456789abcdefghijklmnopqrstuv"; + int num_minors = strlen(ptyminors); + int num_ptys = strlen(ptymajors) * num_minors; + +#if PTY_DEBUG + if (print_debug) + fprintf(stderr, "trying BSD /dev/pty??...\n"); +#endif + for (i = 0; i < num_ptys; i++) { + sprintf(buf, "/dev/pty%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + sprintf(tbuf, "/dev/tty%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + + /* Try SCO style naming */ + sprintf(buf, "/dev/ptyp%d", i); + sprintf(tbuf, "/dev/ttyp%d", i); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + + /* Try BeOS style naming */ + sprintf(buf, "/dev/pt/%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + sprintf(tbuf, "/dev/tt/%c%c", + ptymajors[i / num_minors], + ptyminors[i % num_minors]); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + + /* Try z/OS style naming */ + sprintf(buf, "/dev/ptyp%04d", i); + sprintf(tbuf, "/dev/ttyp%04d", i); + if (strlcpy(namebuf, tbuf, namebuflen) >= namebuflen) { + warn("ERROR: pty_allocate: ttyname truncated"); + return 0; + } + *ptyfd = open(buf, O_RDWR | O_NOCTTY); + if (*ptyfd >= 0 && open_slave(ptyfd, ttyfd, namebuf, namebuflen)) + break; + + namebuf[0] = 0; + } + if (*ptyfd >= 0) + break; + } + + } while (0); + + if (*ptyfd < 0 || namebuf[0] == 0) + return 0; /* we failed to allocate one */ + + return 1; /* whew, finally finished successfully */ +} /* end allocate_pty */ + + + +MODULE = IO::Tty PACKAGE = IO::Pty + +PROTOTYPES: DISABLE + +void +pty_allocate() + INIT: + int ptyfd, ttyfd, ret; + char name[256]; +#ifdef PTY_DEBUG + SV *debug; +#endif + + PPCODE: +#ifdef PTY_DEBUG + debug = perl_get_sv("IO::Tty::DEBUG", FALSE); + if (SvTRUE(debug)) + print_debug = 1; +#endif + ret = allocate_pty(&ptyfd, &ttyfd, name, sizeof(name)); + if (ret) { + name[sizeof(name)-1] = 0; + EXTEND(SP,3); + PUSHs(sv_2mortal(newSViv(ptyfd))); + PUSHs(sv_2mortal(newSViv(ttyfd))); + PUSHs(sv_2mortal(newSVpv(name, strlen(name)))); + } else { + /* empty list */ + } + + +MODULE = IO::Tty PACKAGE = IO::Tty + +char * +ttyname(handle) +InOutStream handle + CODE: +#ifdef HAVE_TTYNAME + if (handle) + RETVAL = ttyname(PerlIO_fileno(handle)); + else { + RETVAL = Nullch; + errno = EINVAL; + } +#else + warn("IO::Tty::ttyname not implemented on this architecture"); + RETVAL = Nullch; +#endif + OUTPUT: + RETVAL + +SV * +pack_winsize(row, col, xpixel = 0, ypixel = 0) + int row + int col + int xpixel + int ypixel + INIT: + struct winsize ws; + CODE: + ws.ws_row = row; + ws.ws_col = col; + ws.ws_xpixel = xpixel; + ws.ws_ypixel = ypixel; + RETVAL = newSVpvn((char *)&ws, sizeof(ws)); + OUTPUT: + RETVAL + +void +unpack_winsize(winsize) + SV *winsize; + INIT: + struct winsize ws; + PPCODE: + if(SvCUR(winsize) != sizeof(ws)) + croak("IO::Tty::unpack_winsize(): Bad arg length - got %zd, expected %zd", + SvCUR(winsize), sizeof(ws)); + Copy(SvPV_nolen(winsize), &ws, sizeof(ws), char); + EXTEND(SP, 4); + PUSHs(sv_2mortal(newSViv(ws.ws_row))); + PUSHs(sv_2mortal(newSViv(ws.ws_col))); + PUSHs(sv_2mortal(newSViv(ws.ws_xpixel))); + PUSHs(sv_2mortal(newSViv(ws.ws_ypixel))); + + +BOOT: +{ + HV *stash; + SV *config; + + stash = gv_stashpv("IO::Tty::Constant", TRUE); + config = perl_get_sv("IO::Tty::CONFIG", TRUE); +#include "xssubs.c" +} + + diff --git a/src/IO-Tty-1.17/t/pty_get_winsize.t b/src/IO-Tty-1.17/t/pty_get_winsize.t new file mode 100644 index 0000000000000000000000000000000000000000..a55f9a565680a140f2ea9ea79542d0958f5c9d03 --- /dev/null +++ b/src/IO-Tty-1.17/t/pty_get_winsize.t @@ -0,0 +1,28 @@ +#!/usr/bin/env perl -w + +use strict; +use warnings; + +use Test::More; + +if ( $^O =~ m!^(solaris|nto)$! ) { + plan skip_all => 'Problems on Solaris and QNX with this test'; +} +else { + plan tests => 1; +} + +use IO::Pty (); + +my @warnings; + +{ + local $^W = 1; + + local $SIG{'__WARN__'} = sub { push @warnings, @_ }; + + my $pty = IO::Pty->new(); + () = $pty->get_winsize(); +} + +is_deeply( \@warnings, [], 'get_winsize() doesn’t warn' ); diff --git a/src/IO-Tty-1.17/t/test.t b/src/IO-Tty-1.17/t/test.t new file mode 100644 index 0000000000000000000000000000000000000000..ac3a2192c810496ad4bc8179261d9f04abd1d1a6 --- /dev/null +++ b/src/IO-Tty-1.17/t/test.t @@ -0,0 +1,240 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 5; + +$^W = 1; # enable warnings +use IO::Pty; +use IO::Tty qw(TIOCSCTTY TIOCNOTTY TCSETCTTY); + +$IO::Tty::DEBUG = 1; +require POSIX; + +my $Perl = $^X; + +diag("Configuration: $IO::Tty::CONFIG"); +diag("Checking for appropriate ioctls:"); +diag("TIOCNOTTY") if defined TIOCNOTTY; +diag("TIOCSCTTY") if defined TIOCSCTTY; +diag("TCSETCTTY") if defined TCSETCTTY; + +{ + my $pid = fork(); + die "Cannot fork" if not defined $pid; + unless ($pid) { + + # child closes stdin/out and reports test result via exit status + sleep 0; + close STDIN; + close STDOUT; + my $master = new IO::Pty; + my $slave = $master->slave(); + + my $master_fileno = $master->fileno; + my $slave_fileno = $slave->fileno; + + $master->close(); + if ( $master_fileno < 3 or $slave_fileno < 3 ) { # altered + die("ERROR: masterfd=$master_fileno, slavefd=$slave_fileno"); # altered + } + exit(0); + } + + is( wait, $pid, "fork exits with 0 exit code" ) or die("Wrong child"); + is( $?, 0, "0 exit code from forked child - Checking that returned fd's don't clash with stdin/out/err" ); +} + +{ + diag(" === Checking if child gets pty as controlling terminal"); + + my $master = new IO::Pty; + + pipe( FROM_CHILD, TO_PARENT ) + or die "Cannot create pipe: $!"; + my $pid = fork(); + die "Cannot fork" if not defined $pid; + unless ($pid) { + + # child + sleep(1); + $master->make_slave_controlling_terminal(); + my $slave = $master->slave(); + close $master; + close FROM_CHILD; + print TO_PARENT "\n"; + close TO_PARENT; + open( TTY, "+>/dev/tty" ) or die "no controlling terminal"; + autoflush TTY 1; + print TTY "gimme on /dev/tty: "; + my $s = ; + chomp $s; + print $slave "back on STDOUT: \U$s\n"; + close TTY; + close $slave; + sleep(1); + exit 0; + } + + close TO_PARENT; + $master->close_slave(); + my $dummy; + my $stat = sysread( FROM_CHILD, $dummy, 1 ); + die "Cannot sync with child: $!" if not $stat; + close FROM_CHILD; + + my ( $s, $chunk ); + $SIG{ALRM} = sub { die("Timeout ($s)"); }; + alarm(10); + + sysread( $master, $s, 100 ) or die "sysread() failed: $!"; + like( $s, qr/gimme.*:/, "master object outputs: '$s'" ); + + print $master "seems OK!\n"; + + # collect all responses + my $ret; + while ( $ret = sysread( $master, $chunk, 100 ) ) { + $s .= $chunk; + } + like( $s, qr/back on STDOUT: SEEMS OK!/, "STDOUT looks right" ); + warn <<"_EOT_" unless defined $ret; + +WARNING: when the client closes the slave pty, the master gets an error +(undef return value and \$! eq "$!") +instead of EOF (0 return value). Please be sure to handle this +in your application (Expect already does). + +_EOT_ + + alarm(0); + kill TERM => $pid; +} + +# now for the echoback tests +diag( + "Checking basic functionality and how your ptys handle large strings... + This test may hang on certain systems, even though it is protected + by alarm(). If the counter stops, try Ctrl-C, the test should continue." +); + +{ + my $randstring = + q{fakjdf ijj845jtirg\r8e 4jy8 gfuoyhj\agt8h\0x00 gues98\0xFF 45th guoa\beh gt98hae 45t8u ha8rhg ue4ht 8eh tgo8he4 t8 gfj aoingf9a8hgf uain dgkjadshft+uehgf =usüand9ß87vgh afugh 8*h 98H 978H 7HG zG 86G (&g (O/g &(GF(/EG F78G F87SG F(/G F(/a sldjkf ha\@j<\rksdhf jk>~|ahsd fjkh asdHJKGDSG TRJKSGO JGDSFJDFHJGSDK1%&FJGSDGFSH\0xADJäDGFljkhf lakjs(dh fkjahs djfk hasjkdh fjklahs dfkjhdjkf haöjksdh fkjah sdjf)\$/§&k hasÄÜÖjkdh fkjhuerhtuwe htui eruth ZI AHD BIZA Di7GH )/g98 9 97 86tr(& TA&(t 6t &T 75r 5\$R%/4r76 5&/% R79 5 )/&}; + + my $master = new IO::Pty; + diag( "isatty(\$master): ", POSIX::isatty($master) ? "YES" : "NO" ); + if ( POSIX::isatty($master) ) { + $master->set_raw() + or warn "warning: \$master->set_raw(): $!"; + } + + pipe( FROM_CHILD, TO_PARENT ) + or die "Cannot create pipe: $!"; + my $pid = fork(); + die "Cannot fork" if not defined $pid; + unless ($pid) { + + # child sends back everything inverted + my $c; + my $slave = $master->slave(); + close $master; + diag( "isatty(\$slave): ", POSIX::isatty($slave) ? "YES" : "NO" ); + $slave->set_raw() + or warn "warning: \$slave->set_raw(): $!"; + close FROM_CHILD; + print TO_PARENT "\n"; + close TO_PARENT; + my $cnt = 0; + my $linecnt = 0; + + while (1) { + my $ret = sysread( $slave, $c, 1 ); + warn "sysread(): $!" unless defined $ret; + die "Slave got EOF at line $linecnt, byte $cnt.\n" unless $ret; + $cnt++; + if ( $c eq "\n" ) { + $linecnt++; + $cnt = 0; + } + else { + $c = ~$c; + } + $ret = syswrite( $slave, $c, 1 ); + warn "syswrite(): $!" unless defined $ret; + } + } + close TO_PARENT; + $master->close_slave(); + my $dummy; + my $stat = sysread( FROM_CHILD, $dummy, 1 ); + die "Cannot sync with child: $!" if not $stat; + close FROM_CHILD; + + diag("Child PID = $pid"); + + # parent sends down some strings and expects to get them back inverted + my $maxlen = 0; + foreach my $len ( 1 .. length($randstring) ) { + my $s = substr( $randstring, 0, $len ); + my $buf; + my $ret = ""; + my $inv = ~$s . "\n"; + $s .= "\n"; + my $sendbuf = $s; + $SIG{ALRM} = $SIG{TERM} = $SIG{INT} = sub { die "TIMEOUT(SIG" . shift() . ")"; }; + eval { + alarm(25); + + while ( $sendbuf or length($ret) < length($s) ) { + if ($sendbuf) { + my $sent = syswrite( $master, $sendbuf, length($sendbuf) ); + die "syswrite() failed: $!" unless defined $sent; + $sendbuf = substr( $sendbuf, $sent ); + } + $buf = ""; + my $read = sysread( $master, $buf, length($s) ); + die "Couldn't read from child: $!" if not $read; + $ret .= $buf; + } + alarm(0); + }; + if ($@) { + warn $@; + last; + } + + if ( $ret eq $inv ) { + $maxlen = $len; + } + else { + if ( length($s) == length($ret) ) { + warn "Got back a wrong string with the right length " . length($ret) . "\n"; + } + else { + warn "Got back a wrong string with the wrong length " . length($ret) . " (instead of " . length($s) . ")\n"; + } + ok(0); + last; + } + } + $SIG{ALRM} = $SIG{TERM} = $SIG{INT} = 'DEFAULT'; + if ( $maxlen < length($randstring) ) { + warn <<"_EOT_"; + +WARNING: your raw ptys block when sending more than $maxlen bytes! +This may cause problems under special scenarios, but you probably +will never encounter that problem. + +_EOT_ + } + else { + diag("Good, your raw ptys can handle at least $maxlen bytes at once."); + } + ok( $maxlen >= 200, "\$maxlen >= 200 ($maxlen)" ); + close($master); + sleep(1); + kill TERM => $pid; +} + diff --git a/src/IO-Tty-1.17/try b/src/IO-Tty-1.17/try new file mode 100644 index 0000000000000000000000000000000000000000..160e7096c7191f369b85d8374f54f387fd0373d6 --- /dev/null +++ b/src/IO-Tty-1.17/try @@ -0,0 +1,132 @@ + +use blib; +use IO::Pty; +require POSIX; +$^W = 1; + +my $pty = new IO::Pty; +my $pid; + +unless (@ARGV) { + { + my $slave = $pty->slave; + print %{*$pty},"\n"; + print "master $pty $$pty ",$pty->ttyname,"\n"; + print "slave $slave $$slave ",$slave->ttyname,"\n"; + + foreach $val (1..10) { + print $pty "$val\n"; + $_ = <$slave>; + print "$_"; + } + } + close $pty; + print "Done.\n"; + exit 0; +} else { + pipe(STAT_RDR, STAT_WTR) + or die "Cannot open pipe: $!"; + STAT_WTR->autoflush(1); + $pid = fork(); + die "Cannot fork" if not defined $pid; + unless ($pid) { + close STAT_RDR; + $pty->make_slave_controlling_terminal(); + my $slave = $pty->slave(); + close $pty; + $slave->clone_winsize_from(\*STDIN); + $slave->set_raw(); + + open(STDIN,"<&". $slave->fileno()) + or die "Couldn't reopen STDIN for reading, $!\n"; + open(STDOUT,">&". $slave->fileno()) + or die "Couldn't reopen STDOUT for writing, $!\n"; + open(STDERR,">&". $slave->fileno()) + or die "Couldn't reopen STDERR for writing, $!\n"; + + close $slave; + + { exec(@ARGV) }; + print STAT_WTR $!+0; + die "Cannot exec(@ARGV): $!"; + } + close STAT_WTR; + $pty->close_slave(); + $pty->set_raw(); + # now wait for child exec (eof due to close-on-exit) or exec error + my $errstatus = sysread(STAT_RDR, $errno, 256); + die "Cannot sync with child: $!" if not defined $errstatus; + close STAT_RDR; + if ($errstatus) { + $! = $errno+0; + die "Cannot exec(@ARGV): $!"; + } + $SIG{WINCH} = \&winch; + parent($pty); +} + +sub winch { + $pty->slave->clone_winsize_from(\*STDIN); + kill WINCH => $pid if $pid; + print "STDIN terminal size changed.\n"; + $SIG{WINCH} = \&winch; +} + +sub process +{ + my ($rin,$src,$dst) = @_; + my $buf = ''; + my $read = sysread($src, $buf, 1); + if (defined $read && $read) + { + syswrite($dst,$buf,$read); + syswrite(LOG,$buf,$read); + } + else + { +# print STDERR "Nothing for $src i.e. $read\n"; + vec($rin, fileno($src), 1) = 0; + } + return $rin; +} + +sub parent +{ + open(LOG,">log") || die; + my ($pty) = @_; + my $tty = $pty; + my ($rin,$win,$ein) = ('','',''); + vec($rin, fileno(STDIN), 1) = 1; + vec($rin, fileno($tty), 1) = 1; + vec($win, fileno($tty), 1) = 1; + vec($ein, fileno($tty), 1) = 1; + select($tty); + $| = 1; + select(STDOUT); + $| = 1; + while (1) + { + my ($rout,$wout,$eout,$timeleft); + ($nfound,$timeleft) = select($rout=$rin,$wout=$win,$eout=$ein,3600); + die "select failed:$!" if ($nfound < 0); + if ($nfound > 0) + { + if (vec($eout, fileno($tty), 1)) + { +# print STDERR "Exception on $tty\n"; + } + if (vec($rout, fileno($tty), 1)) + { + $rin = process($rin,$tty,STDOUT); + last unless (vec($rin, fileno($tty), 1)); + } + elsif (vec($rout, fileno(STDIN), 1) && vec($wout, fileno($tty), 1)) + { + $rin = process($rin,STDIN,$tty); + } + } + } + close(LOG); +} + +