pax_global_header00006660000000000000000000000064124046156300014513gustar00rootroot0000000000000052 comment=26091ac423655316335a4b82f886e7faa1d9eb76 IO-Tty-1.12/000077500000000000000000000000001240461563000125235ustar00rootroot00000000000000IO-Tty-1.12/.gitignore000066400000000000000000000001431240461563000145110ustar00rootroot00000000000000/MYMETA.json /MYMETA.yml /Makefile /Tty.bs /Tty.c /Tty.o /Tty/ /blib/ /conf/ /pm_to_blib /xssubs.c IO-Tty-1.12/ChangeLog000066400000000000000000000206671240461563000143100ustar00rootroot000000000000002014-09-12 Todd Rinaldo 1.12 * Merge pull request from Chris Williams (bingos) to fix "redefinition of typedef" errors with v5.19.4 and above 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 2010-10-11 Todd Rinaldo * CPAN testers clean. Bumping to release version 1.10 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 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 2010-10-02 Todd Rinaldo * RT 61642 - Fix file number test to work without hang on cygwin * Bump to 1.08_03 2010-09-10 Todd Rinaldo * Update all versions to the new version. bump to 1.08_02 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 2009-02-05 Roland Giersig * v1.08 * Makefile.PL, Tty.xs: added support for posix_openpt(), thanks to Ed Schouten for providing a patch 2006-07-18 Roland Giersig * v1.07 * Tty.xs: added some more letter to BSD allocation 2006-07-15 Roland Giersig * v1.06 * Tty.pm: pre-allocate buffer for ioctl 2006-06-06 Roland Giersig * v1.05 * Tty.xs: added includes and 2006-05-28 Roland Giersig * v1.04 * Tty.xs: added handling for z/OS (uses /dev/ptyp0000) * Makefile.PL: added (for HPUX) 2006-04-25 Roland Giersig * v1.03 * 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 2002-04-02 Roland Giersig * Tty.pm, Pty.pm: v1.02; disable warning for non-existant die handler 2002-03-18 Roland Giersig * v1.01 * Makefile.PL: remove cpp, test-compile instead * Tty.pm, Pty.pm: disable die handler when requiring Stty 2002-03-06 Roland Giersig * v0.97_04, final pre-release version 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 IO-Tty-1.12/MANIFEST000066400000000000000000000002271240461563000136550ustar00rootroot00000000000000ChangeLog MANIFEST Makefile.PL Pty.pm README Tty.pm Tty.xs try t/test.t META.yml Module meta-data (added by MakeMaker) IO-Tty-1.12/META.json000066400000000000000000000016361240461563000141520ustar00rootroot00000000000000{ "abstract" : "Pseudo ttys and constants", "author" : [ "Roland Giersig " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.120921", "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" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/toddr/IO-Tty" } }, "version" : "1.12" } IO-Tty-1.12/META.yml000066400000000000000000000010141240461563000137700ustar00rootroot00000000000000--- 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 6.68, CPAN::Meta::Converter version 2.120921' 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 requires: {} resources: repository: https://github.com/toddr/IO-Tty version: '1.12' IO-Tty-1.12/Makefile.PL000066400000000000000000000330641240461563000145030ustar00rootroot00000000000000use 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 IO::File; use Config qw(%Config); my %cfg; @cfg{qw(cc ccflags ldflags)} = @Config{qw(cc ccflags ldflags)}; for my $arg (@ARGV) { if ( /^(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.12'; # 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; 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; 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 _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_; =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'}, 'MAP_TARGET' => 'perltty', 'AUTHOR' => 'Roland Giersig ', 'ABSTRACT' => 'Pseudo ttys and constants', 'LICENSE' => 'perl', 'BUILD_REQUIRES' => { 'Test::More' => 0, # For testing }, 'META_MERGE' => { 'resources' => { 'repository' => 'https://github.com/toddr/IO-Tty', }, }, ); 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); } IO-Tty-1.12/Pty.pm000066400000000000000000000216321240461563000136410ustar00rootroot00000000000000# 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.12'; # 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 (not POSIX::setsid()) { 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.12 =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-dependend. 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 IO-Tty-1.12/README000066400000000000000000000032261240461563000134060ustar00rootroot00000000000000IO::Tty and IO::Pty provide an interface to pseudo tty's To build this distribution, run perl Makefile.PL make make test make install This version (v1.08) now adds posix_openpt() as a means of allocating the pty, thanks goes to Ed Schouten who provided a patch. Please note that pty creation is very system-dependend, and there are a *lot* of different systems out there. If you have problems on your system, please send me () the output of a manual installation ('perl Makefile.PL; make; make test;') and I'll see what I can deduce from it. Supported systems include Linux, Solaris, AIX, OSF, *BSD, IRIX, HP-UX and Darwin. Windows is supported only under the Cygwin environment, see http://www.cygwin.com/. Sorry, ActiveState Perl on Windows is NOT supported, basically because there are no pseudo-terminals under Windows. 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! See the ChangeLog and the docs for details. Oh, and many thanks to all testers, without their support this project would still be limited to a few systems that I have access to. Thanks also to SourceForge (http://sf.net) who is hosting this and many other projects, their services have made development and support a real pleasure. If you intend to donate something to the Open Source cause, think about lending them a machine with a commercial OS license for their compile farm! Roland 2009-02-23 IO-Tty-1.12/Tty.pm000066400000000000000000000176401240461563000136510ustar00rootroot00000000000000# Documentation at the __END__ # -*-cperl-*- package IO::Tty; 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.12'; $XS_VERSION = "1.12"; @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 = " "x1024; # preallocate memory 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; ioctl($self, IO::Tty::Constant::TIOCGWINSZ(), my $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.12 =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 IO-Tty-1.12/Tty.xs000066400000000000000000000550041240461563000136630ustar00rootroot00000000000000#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 # if ((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 (*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 %d, expected %d", 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" } IO-Tty-1.12/t/000077500000000000000000000000001240461563000127665ustar00rootroot00000000000000IO-Tty-1.12/t/test.t000066400000000000000000000162121240461563000141340ustar00rootroot00000000000000#!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) ) { print STDERR "$len\r"; 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(15); 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; } IO-Tty-1.12/try000066400000000000000000000055001240461563000132640ustar00rootroot00000000000000 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); }