r1225 - in packages: . libterm-readkey-perl
libterm-readkey-perl/branches libterm-readkey-perl/branches/upstream
libterm-readkey-perl/branches/upstream/current
Gunnar Wolf
gwolf at costa.debian.org
Tue Jul 12 11:56:20 UTC 2005
Author: gwolf
Date: 2005-07-12 11:56:20 +0000 (Tue, 12 Jul 2005)
New Revision: 1225
Added:
packages/libterm-readkey-perl/
packages/libterm-readkey-perl/branches/
packages/libterm-readkey-perl/branches/upstream/
packages/libterm-readkey-perl/branches/upstream/current/
packages/libterm-readkey-perl/branches/upstream/current/Configure.pm
packages/libterm-readkey-perl/branches/upstream/current/MANIFEST
packages/libterm-readkey-perl/branches/upstream/current/Makefile.PL
packages/libterm-readkey-perl/branches/upstream/current/README
packages/libterm-readkey-perl/branches/upstream/current/ReadKey.pm
packages/libterm-readkey-perl/branches/upstream/current/ReadKey.xs
packages/libterm-readkey-perl/branches/upstream/current/genchars.pl
packages/libterm-readkey-perl/branches/upstream/current/ppport.h
packages/libterm-readkey-perl/branches/upstream/current/test.pl
packages/libterm-readkey-perl/tags/
Log:
[svn-inject] Installing original source of libterm-readkey-perl
Added: packages/libterm-readkey-perl/branches/upstream/current/Configure.pm
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/Configure.pm 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/Configure.pm 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,869 @@
+#!/usr/bin/perl
+
+# Configure.pm. Version 1.00 Copyright (C) 1995, Kenneth Albanowski
+#
+# You are welcome to use this code in your own perl modules, I just
+# request that you don't distribute modified copies without making it clear
+# that you have changed something. If you have a change you think is worth
+# merging into the original, please contact me at kjahds at kjahds.com or
+# CIS:70705,126
+#
+# $Id: Configure.pm,v 1.2 2002/01/28 18:40:18 gellyfish Exp $
+#
+
+# Todo: clean up redudant code in CPP, Compile, Link, and Execute
+#
+
+package Configure;
+
+use strict;
+
+use vars qw(@EXPORT @ISA);
+
+use Carp;
+require Exporter;
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw( CPP
+ Compile
+ Link
+ Execute
+ FindHeader
+ FindLib
+ Apply
+ ApplyHeaders
+ ApplyLibs
+ ApplyHeadersAndLibs
+ ApplyHeadersAndLibsAndExecute
+ CheckHeader
+ CheckStructure
+ CheckField
+ CheckHSymbol
+ CheckSymbol
+ CheckLSymbol
+ GetSymbol
+ GetTextSymbol
+ GetNumericSymbol
+ GetConstants);
+
+use Cwd;
+use Config;
+
+my ($C_usrinc, $C_libpth, $C_cppstdin, $C_cppflags, $C_cppminus,
+$C_ccflags,$C_ldflags,$C_cc,$C_libs) =
+ @Config{qw( usrinc libpth cppstdin cppflags cppminus
+ ccflags ldflags cc libs)};
+
+my $Verbose = 0;
+
+=head1 NAME
+
+Configure.pm - provide auto-configuration utilities
+
+=head1 SUMMARY
+
+This perl module provides tools to figure out what is present in the C
+compilation environment. This is intended mostly for perl extensions to use
+to configure themselves. There are a number of functions, with widely varying
+levels of specificity, so here is a summary of what the functions can do:
+
+
+CheckHeader: Look for headers.
+
+CheckStructure: Look for a structure.
+
+CheckField: Look for a field in a structure.
+
+CheckHSymbol: Look for a symbol in a header.
+
+CheckLSymbol: Look for a symbol in a library.
+
+CheckSymbol: Look for a symbol in a header and library.
+
+GetTextSymbol: Get the contents of a symbol as text.
+
+GetNumericSymbol: Get the contents of a symbol as a number.
+
+Apply: Try compiling code with a set of headers and libs.
+
+ApplyHeaders: Try compiling code with a set of headers.
+
+ApplyLibraries: Try linking code with a set of libraries.
+
+ApplyHeadersAndLibaries: You get the idea.
+
+ApplyHeadersAndLibariesAnExecute: You get the idea.
+
+CPP: Feed some code through the C preproccessor.
+
+Compile: Try to compile some C code.
+
+Link: Try to compile & link some C code.
+
+Execute: Try to compile, link, & execute some C code.
+
+=head1 FUNCTIONS
+
+=cut
+
+# Here we go into the actual functions
+
+=head2 CPP
+
+Takes one or more arguments. The first is a string containing a C program.
+Embedded newlines are legal, the text simply being stuffed into a temporary
+file. The result is then fed to the C preproccessor (that preproccessor being
+previously determined by perl's Configure script.) Any additional arguments
+provided are passed to the preprocessing command.
+
+In a scalar context, the return value is either undef, if something went wrong,
+or the text returned by the preprocessor. In an array context, two values are
+returned: the numeric exit status and the output of the preproccessor.
+
+=cut
+
+sub CPP { # Feed code to preproccessor, returning error value and output
+
+ my($code, at options) = @_;
+ my($options) = join(" ", at options);
+ my($file) = "tmp$$";
+ my($in,$out) = ($file.".c",$file.".o");
+
+ open(F,">$in");
+ print F $code;
+ close(F);
+
+ print "Preprocessing |$code|\n" if $Verbose;
+ my($result) = scalar(`$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null`);
+ print "Executing '$C_cppstdin $C_cppflags $C_cppminus $options < $in 2>/dev/null'\n" if $Verbose;
+
+
+ my($error) = $?;
+ print "Returned |$result|\n" if $Verbose;
+ unlink($in,$out);
+ return ($error ? undef : $result) unless wantarray;
+ ($error,$result);
+}
+
+=head2 Compile
+
+Takes one or more arguments. The first is a string containing a C program.
+Embedded newlines are legal, the text simply being stuffed into a temporary
+file. The result is then fed to the C compiler (that compiler being
+previously determined by perl's Configure script.) Any additional arguments
+provided are passed to the compiler command.
+
+In a scalar context, either 0 or 1 will be returned, with 1 indicating a
+successful compilation. In an array context, three values are returned: the
+numeric exit status of the compiler, a string consisting of the output
+generated by the compiler, and a numeric value that is false if a ".o" file
+wasn't produced by the compiler, error status or no.
+
+=cut
+
+sub Compile { # Feed code to compiler. On error, return status and text
+ my($code, at options) = @_;
+ my($options)=join(" ", at options);
+ my($file) = "tmp$$";
+ my($in,$out) = ($file.".c",$file.".o");
+
+ open(F,">$in");
+ print F $code;
+ close(F);
+ print "Compiling |$code|\n" if $Verbose;
+ my($result) = scalar(`$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1`);
+ print "Executing '$C_cc $C_ccflags -c $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
+ my($error) = $?;
+ my($error2) = ! -e $out;
+ unlink($in,$out);
+ return (($error || $error2) ? 0 : 1) unless wantarray;
+ ($error,$result,$error2);
+}
+
+=head2 Link
+
+Takes one or more arguments. The first is a string containing a C program.
+Embedded newlines are legal, the text simply being stuffed into a temporary
+file. The result is then fed to the C compiler and linker (that compiler and
+linker being previously determined by perl's Configure script.) Any
+additional arguments provided are passed to the compilation/link command.
+
+In a scalar context, either 0 or 1 is returned, with 1 indicating a
+successful compilation. In an array context, two values are returned: the
+numeric exit status of the compiler/linker, and a string consisting of the
+output generated by the compiler/linker.
+
+Note that this command I<only> compiles and links the C code. It does not
+attempt to execute it.
+
+=cut
+
+sub Link { # Feed code to compiler and linker. On error, return status and text
+ my($code, at options) = @_;
+ my($options) = join(" ", at options);
+ my($file) = "tmp$$";
+ my($in,$out) = $file.".c",$file.".o";
+
+ open(F,">$in");
+ print F $code;
+ close(F);
+ print "Linking |$code|\n" if $Verbose;
+ my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`);
+ print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
+ my($error)=$?;
+ print "Error linking: $error, |$result|\n" if $Verbose;
+ unlink($in,$out,$file);
+ return (($error || $result ne "")?0:1) unless wantarray;
+ ($error,$result);
+}
+
+=head2 Execute
+
+Takes one or more arguments. The first is a string containing a C program.
+Embedded newlines are legal, the text simply being stuffed into a temporary
+file. The result is then fed to the C compiler and linker (that compiler and
+linker being previously determined by perl's metaconfig script.) and then
+executed. Any additional arguments provided are passed to the
+compilation/link command. (There is no way to feed arguments to the program
+being executed.)
+
+In a scalar context, the return value is either undef, indicating the
+compilation or link failed, or that the executed program returned a nonzero
+status. Otherwise, the return value is the text output by the program.
+
+In an array context, an array consisting of three values is returned: the
+first value is 0 or 1, 1 if the compile/link succeeded. The second value either
+the exist status of the compiler or program, and the third is the output text.
+
+=cut
+
+sub Execute { #Compile, link, and execute.
+
+ my($code, at options) = @_;
+ my($options)=join(" ", at options);
+ my($file) = "tmp$$";
+ my($in,$out) = $file.".c",$file.".o";
+
+ open(F,">$in");
+ print F $code;
+ close(F);
+ print "Executing |$code|\n" if $Verbose;
+ my($result) = scalar(`$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1`);
+ print "Executing '$C_cc $C_ccflags -o $file $in $C_ldflags $C_libs $options 2>&1'\n" if $Verbose;
+ my($error) = $?;
+ unlink($in,$out);
+ if(!$error) {
+ my($result2) = scalar(`./$file`);
+ $error = $?;
+ unlink($file);
+ return ($error?undef:$result2) unless wantarray;
+ print "Executed successfully, status $error, link $result, exec |$result2|\n" if $Verbose;
+ (1,$error,$result2);
+ } else {
+ print "Link failed, status $error, message |$result|\n" if $Verbose;
+ return undef unless wantarray;
+ (0,$error,$result);
+ }
+}
+
+=head2 FindHeader
+
+Takes an unlimited number of arguments, consisting of both header names in
+the form "header.h", or directory specifications such as "-I/usr/include/bsd".
+For each supplied header, FindHeader will attempt to find the complete path.
+The return value is an array consisting of all the headers that were located.
+
+=cut
+
+sub FindHeader { #For each supplied header name, find full path
+ my(@headers) = grep(!/^-I/, at _);
+ my(@I) = grep(/^-I/, at _);
+ my($h);
+ for $h (@headers) {
+ print "Searching for $h... " if $Verbose;
+ if($h eq "") {$h=undef; next}
+ if( -f $h) {next}
+ if( -f $Config{"usrinc"}."/".$h) {
+ $h = $Config{"usrinc"}."/".$h;
+ print "Found as $h.\n" if $Verbose;
+ } else {
+ my $text;
+ if($text = CPP("#include <$h>",join(" ", at I))) {
+ grepcpp:
+ for (split(/\s+/,(grep(/^\s*#.*$h/,split(/\n/,$text)))[0])) {
+ if(/$h/) {
+ s/^\"(.*)\"$/$1/;
+ s/^\'(.*)\'$/$1/;
+ $h = $_;
+ print "Found as $h.\n" if $Verbose;
+ last grepcpp;
+ }
+ }
+ } else {
+ $h = undef; # remove header from resulting list
+ print "Not found.\n" if $Verbose;
+ }
+ }
+ }
+ grep($_, at headers);
+}
+
+=head2 FindLib
+
+Takes an unlimited number of arguments, consisting of both library names in
+the form "-llibname", "/usr/lib/libxyz.a" or "dld", or directory
+specifications such as "-L/usr/lib/foo". For each supplied library, FindLib
+will attempt to find the complete path. The return value is an array
+consisting of the full paths to all of the libraries that were located.
+
+=cut
+
+sub FindLib { #For each supplied library name, find full path
+ my(@libs) = grep(!/^-L/, at _);
+ my(@L) = (grep(/^-L/, at _),split(" ",$Config{"libpth"}));
+ grep(s/^-L//, at L);
+ my($l);
+ my($so) = $Config{"so"};
+ my($found);
+ #print "Libaries I am searching for: ",join(",", at libs),"\n";
+ #print "Directories: ",join(",", at L),"\n";
+ my $lib;
+ for $lib (@libs) {
+ print "Searching for $lib... " if $Verbose;
+ $found=0;
+ $lib =~ s/^-l//;
+ if($lib eq "") {$lib=undef; next}
+ next if -f $lib;
+ my $path;
+ for $path (@L) {
+ my ( $fullname, @fullname );
+ print "Searching $path for $lib...\n" if $Verbose;
+ if (@fullname=<${path}/lib${lib}.${so}.[0-9]*>){
+ $fullname=$fullname[-1]; #ATTN: 10 looses against 9!
+ } elsif (-f ($fullname="$path/lib$lib.$so")){
+ } elsif (-f ($fullname="$path/lib${lib}_s.a")
+ && ($lib .= "_s") ){ # we must explicitly ask for _s version
+ } elsif (-f ($fullname="$path/lib$lib.a")){
+ } elsif (-f ($fullname="$path/Slib$lib.a")){
+ } else {
+ warn "$lib not found in $path\n" if $Verbose;
+ next;
+ }
+ warn "'-l$lib' found at $fullname\n" if $Verbose;
+ $lib = $fullname;
+ $found=1;
+ }
+ if(!$found) {
+ $lib = undef; # Remove lib if not found
+ print "Not found.\n" if $Verbose;
+ }
+ }
+ grep($_, at libs);
+}
+
+
+=head2
+
+Apply takes a chunk of code, a series of libraries and headers, and attempts
+to apply them, in series, to a given perl command. In a scalar context, the
+return value of the first set of headers and libraries that produces a
+non-zero return value from the command is returned. In an array context, the
+header and library set it returned.
+
+This is best explained by some examples:
+
+ Apply(\&Compile,"main(){}","sgtty.h","");
+
+In a scalar context either C<undef> or C<1>. In an array context,
+this returns C<()> or C<("sgtty.h","")>.
+
+ Apply(\&Link,"main(){int i=COLOR_PAIRS;}","curses.h","-lcurses",
+ "ncurses.h","-lncurses","ncurses/ncurses.h","-lncurses");
+
+In a scalar context, this returns either C<undef>, C<1>. In an array context,
+this returns C<("curses.h","-lcurses")>, C<("ncurses.h","-lncurses")>,
+C<("ncurses/ncurses.h","-lncurses")>, or C<()>.
+
+If we had instead said
+C<Apply(\&Execute,'main(){printf("%d",(int)COLOR_PAIRS)',...)> then in a scalar
+context either C<undef> or the value of COLOR_PAIRS would be returned.
+
+Note that you can also supply multiple headers and/or libraries at one time,
+like this:
+
+ Apply(\&Compile,"main(){fcntl(0,F_GETFD);}","fcntl.h","",
+ "ioctl.h fcntl.h","","sys/ioctl.h fcntl.h"","");
+
+So if fcntl needs ioctl or sys/ioctl loaded first, this will catch it. In an
+array context, C<()>, C<("fcntl.h","")>, C<("ioctl.h fcntl.h","")>, or
+C<("sys/ioctl.h fcntl.h","")> could be returned.
+
+You can also use nested arrays to get exactly the same effect. The returned
+array will always consist of a string, though, with elements separated by
+spaces.
+
+ Apply(\&Compile,"main(){fcntl(0,F_GETFD);}",["fcntl.h"],"",
+ ["ioctl.h","fcntl.h"],"",["sys/ioctl.h","fcntl.h"],"");
+
+Note that there are many functions that provide simpler ways of doing these
+things, from GetNumericSymbol to get the value of a symbol, to ApplyHeaders
+which doesn't ask for libraries.
+
+=cut
+
+sub Apply { #
+ my($cmd,$code, at lookup) = @_;
+ my(@l, at h,$i,$ret);
+ for ($i=0;$i<@lookup;$i+=2) {
+ if( ref($lookup[$i]) eq "ARRAY" ) {
+ @h = @{$lookup[$i]};
+ } else {
+ @h = split(/\s+/,$lookup[$i]);
+ }
+ if( ref($lookup[$i+1]) eq "ARRAY" ) {
+ @l = @{$lookup[$i+1]};
+ } else {
+ @l = split(/\s+/,$lookup[$i+1]);
+ }
+
+ if($ret=&{$cmd == \&Link && !@l?\&Compile:$cmd}(join("",map($_?"#include <$_>\n":"",grep(!/^-I/, at h))).
+ $code,grep(/^-I/, at h), at l)) {
+ print "Ret=|$ret|\n" if $Verbose;
+ return $ret unless wantarray;
+ return (join(" ", at h),join(" ", at l));
+ }
+ }
+ return 0 unless wantarray;
+ ();
+}
+
+=head2 ApplyHeadersAndLibs
+
+This function takes the same sort of arguments as Apply, it just sends them
+directly to Link.
+
+=cut
+
+sub ApplyHeadersAndLibs { #
+ my($code, at lookup) = @_;
+ Apply \&Link,$code, at lookup;
+}
+
+=head2 ApplyHeadersAndLibsAndExecute
+
+This function is similar to Apply and ApplyHeadersAndLibs, but it always
+uses Execute.
+
+=cut
+
+sub ApplyHeadersAndLibsAndExecute { #
+ my($code, at lookup) = @_;
+ Apply \&Execute,$code, at lookup;
+}
+
+=head2 ApplyHeaders
+
+If you are only checking headers, and don't need to look at libs, then
+you will probably want to use ApplyHeaders. The return value is the same
+in a scalar context, but in an array context the returned array will only
+consists of the headers, spread out.
+
+=cut
+
+sub ApplyHeaders {
+ my($code, at headers) = @_;
+ return scalar(ApplyHeadersAndLibs $code, map(($_,""), at headers))
+ unless wantarray;
+ split(/\s+/,(ApplyHeadersAndLibs $code, map(($_,""), at headers))[0]);
+}
+
+=head2 ApplyLibs
+
+If you are only checking libraries, and don't need to look at headers, then
+you will probably want to use ApplyLibs. The return value is the same
+in a scalar context, but in an array context the returned array will only
+consists of the libraries, spread out.
+
+=cut
+
+sub ApplyLibs {
+ my($code, at libs) = @_;
+ return scalar(ApplyHeadersAndLibs $code, map(("",$_), at libs))
+ unless wantarray;
+ split(/\s+/,(ApplyHeadersAndLibs $code, map(("",$_), at libs))[0]);
+}
+
+=head2 CheckHeader
+
+Takes an unlimited number of arguments, consiting of headers in the
+Apply style. The first set that is fully accepted
+by the compiler is returned.
+
+=cut
+
+sub CheckHeader { #Find a header (or set of headers) that exists
+ ApplyHeaders("main(){}", at _);
+}
+
+=head2 CheckStructure
+
+Takes the name of a structure, and an unlimited number of further arguments
+consisting of header groups. The first group that defines that structure
+properly will be returned. B<undef> will be returned if nothing succeeds.
+
+=cut
+
+sub CheckStructure { # Check existance of a structure.
+ my($structname, at headers) = @_;
+ ApplyHeaders("main(){ struct $structname s;}", at headers);
+}
+
+=head2 CheckField
+
+Takes the name of a structure, the name of a field, and an unlimited number
+of further arguments consisting of header groups. The first group that
+defines a structure that contains the field will be returned. B<undef> will
+be returned if nothing succeeds.
+
+=cut
+
+sub CheckField { # Check for the existance of specified field in structure
+ my($structname,$fieldname, at headers) = @_;
+ ApplyHeaders("main(){ struct $structname s1; struct $structname s2;
+ s1.$fieldname = s2.$fieldname; }", at headers);
+}
+
+=head2 CheckLSymbol
+
+Takes the name of a symbol, and an unlimited number of further arguments
+consisting of library groups. The first group of libraries that defines
+that symbol will be returned. B<undef> will be returned if nothing succeeds.
+
+=cut
+
+sub CheckLSymbol { # Check for linkable symbol
+ my($symbol, at libs) = @_;
+ ApplyLibs("main() { void * f = (void *)($symbol); }", at libs);
+}
+
+=head2 CheckSymbol
+
+Takes the name of a symbol, and an unlimited number of further arguments
+consisting of header and library groups, in the Apply format. The first
+group of headers and libraries that defines that symbol will be returned.
+B<undef> will be returned if nothing succeeds.
+
+=cut
+
+sub CheckSymbol { # Check for linkable/header symbol
+ my($symbol, at lookup) = @_;
+ ApplyHeadersAndLibs("main() { void * f = (void *)($symbol); }", at lookup);
+}
+
+=head2 CheckHSymbol
+
+Takes the name of a symbol, and an unlimited number of further arguments
+consisting of header groups. The first group of headers that defines
+that symbol will be returned. B<undef> will be returned if nothing succeeds.
+
+=cut
+
+sub CheckHSymbol { # Check for header symbol
+ my($symbol, at headers) = @_;
+ ApplyHeaders("main() { void * f = (void *)($symbol); }", at headers);
+}
+
+=head2 CheckHPrototype (unexported)
+
+An experimental routine that takes a name of a function, a nested array
+consisting of the prototype, and then the normal header groups. It attempts
+to deduce whether the given prototype matches what the header supplies.
+Basically, it doesn't work. Or maybe it does. I wouldn't reccomend it,
+though.
+
+=cut
+
+sub CheckHPrototype { # Check for header prototype.
+ # Note: This function is extremely picky about "const int" versus "int",
+ # and depends on having an extremely snotty compiler. Anything but GCC
+ # may fail, and even GCC may not work properly. In any case, if the
+ # names function doesn't exist, this call will _succeed_. Caveat Utilitor.
+ my($function,$proto, at headers) = @_;
+ my(@proto) = @{$proto};
+ ApplyHeaders("main() { extern ".$proto[0]." $function(".
+ join(",", at proto[1..$#proto])."); }", at headers);
+}
+
+=head2 GetSymbol
+
+Takes the name of a symbol, a printf command, a cast, and an unlimited
+number of further arguments consisting of header and library groups, in the
+Apply. The first group of headers and libraries that defines that symbol
+will be used to get the contents of the symbol in the format, and return it.
+B<undef> will be returned if nothing defines that symbol.
+
+Example:
+
+ GetSymbol("__LINE__","ld","long","","");
+
+=cut
+
+sub GetSymbol { # Check for linkable/header symbol
+ my($symbol,$printf,$cast, at lookup) = @_,"","";
+ scalar(ApplyHeadersAndLibsAndExecute(
+ "main(){ printf(\"\%$printf\",($cast)($symbol));exit(0);}", at lookup));
+}
+
+=head2 GetTextSymbol
+
+Takes the name of a symbol, and an unlimited number of further arguments
+consisting of header and library groups, in the ApplyHeadersAndLibs format.
+The first group of headers and libraries that defines that symbol will be
+used to get the contents of the symbol in text format, and return it.
+B<undef> will be returned if nothing defines that symbol.
+
+Note that the symbol I<must> actually be text, either a char* or a constant
+string. Otherwise, the results are undefined.
+
+=cut
+
+sub GetTextSymbol { # Check for linkable/header symbol
+ my($symbol, at lookup) = @_,"","";
+ my($result) = GetSymbol($symbol,"s","char*", at lookup);
+ $result .= "" if defined($result);
+ $result;
+}
+
+=head2 GetNumericSymbol
+
+Takes the name of a symbol, and an unlimited number of further arguments
+consisting of header and library groups, in the ApplyHeadersAndLibs format.
+The first group of headers and libraries that defines that symbol will be
+used to get the contents of the symbol in numeric format, and return it.
+B<undef> will be returned if nothing defines that symbol.
+
+Note that the symbol I<must> actually be numeric, in a format compatible
+with a float. Otherwise, the results are undefined.
+
+=cut
+
+sub GetNumericSymbol { # Check for linkable/header symbol
+ my($symbol, at lookup) = @_,"","";
+ my($result) = GetSymbol($symbol,"f","float", at lookup);
+ $result += 0 if defined($result);
+ $result;
+}
+
+=head2 GetConstants
+
+Takes a list of header names (possibly including -I directives) and attempts
+to grep the specified files for constants, a constant being something #defined
+with a name that matches /[A-Z0-9_]+/. Returns the list of names.
+
+=cut
+
+sub GetConstants { # Try to grep constants out of a header
+ my(@headers) = @_;
+ @headers = FindHeader(@headers);
+ my %seen;
+ my(%results);
+ map($seen{$_}=1, at headers);
+ while(@headers) {
+ $_=shift(@headers);
+ next if !defined($_);
+ open(SEARCHHEADER,"<$_");
+ while(<SEARCHHEADER>) {
+ if(/^\s*#\s*define\s+([A-Z_][A-Za-z0-9_]+)\s+/) {
+ $results{$1} = 1;
+ } elsif(/^\s*#\s*include\s+[<"]?([^">]+)[>"]?/) {
+ my(@include) = FindHeader($1);
+ @include = grep(!$seen{$_},map(defined($_)?$_:(), at include));
+ push(@headers, at include);
+ map($seen{$_}=1, at include);
+ }
+ }
+ close(SEARCHHEADER);
+ }
+ keys %results;
+}
+
+
+=head2 DeducePrototype (unexported)
+
+This one is B<really> experimental. The idea is to figure out some basic
+characteristics of the compiler, and then attempt to "feel out" the prototype
+of a function. Eventually, it may work. It is guaranteed to be very slow,
+and it may simply not be capable of working on some systems.
+
+=cut
+
+my $firstdeduce = 1;
+sub DeducePrototype {
+
+ my (@types, $checkreturn, $checknilargs, $checkniletcargs, $checkreturnnil);
+
+ if($firstdeduce) {
+ $firstdeduce=0;
+ my $checknumber=!Compile("extern int func(int a,int b);
+ extern int func(int a,int b,int c);
+ main(){}");
+ $checkreturn=!Compile("extern int func(int a,int b);
+ extern long func(int a,int b);
+ main(){}");
+ my $checketc= !Compile("extern int func(int a,int b);
+ extern long func(int a,...);
+ main(){}");
+ my $checknumberetc=!Compile("extern int func(int a,int b);
+ extern int func(int a,int b,...);
+ main(){}");
+ my $checketcnumber=!Compile("extern int func(int a,int b,int c,...);
+ extern int func(int a,int b,...);
+ main(){}");
+ my $checkargtypes=!Compile("extern int func(int a);
+ extern int func(long a);
+ main(){}");
+ my $checkargsnil=!Compile("extern int func();
+ extern int func(int a,int b,int c);
+ main(){}");
+ $checknilargs=!Compile("extern int func(int a,int b,int c);
+ extern int func();
+ main(){}");
+ my $checkargsniletc=!Compile("extern int func(...);
+ extern int func(int a,int b,int c);
+ main(){}");
+ $checkniletcargs=!Compile("extern int func(int a,int b,int c);
+ extern int func(...);
+ main(){}");
+
+ my $checkconst=!Compile("extern int func(const int * a);
+ extern int func(int * a);
+ main(){ }");
+
+ my $checksign=!Compile("extern int func(int a);
+ extern int func(unsigned int a);
+ main(){ }");
+
+ $checkreturnnil=!Compile("extern func(int a);
+ extern void func(int a);
+ main(){ }");
+
+ @types = sort grep(Compile("main(){$_ a;}"),
+ "void","int","long int","unsigned int","unsigned long int","long long int",
+ "long long","unsigned long long",
+ "unsigned long long int","float","long float",
+ "double","long double",
+ "char","unsigned char","short int","unsigned short int");
+
+ if(Compile("main(){flurfie a;}")) { @types = (); }
+
+ $Verbose=0;
+
+ # Attempt to remove duplicate types (if any) from type list
+ my ( $i, $j );
+ if($checkargtypes) {
+ for ($i=0;$i<=$#types;$i++) {
+ for ($j=$i+1;$j<=$#types;$j++) {
+ next if $j==$i;
+ if(Compile("extern void func($types[$i]);
+ extern void func($types[$j]); main(){}")) {
+ print "Removing type $types[$j] because it equals $types[$i]\n";
+ splice(@types,$j,1);
+ $j--;
+ }
+ }
+ }
+ } elsif($checkreturn) {
+ for ($i=0;$i<=$#types;$i++) {
+ for ($j=$i+1;$j<=$#types;$j++) {
+ next if $j==$i;
+ if(Compile("$types[$i] func(void);
+ extern $types[$j] func(void); main(){}")) {
+ print "Removing type $types[$j] because it equals $types[$i]\n";
+ splice(@types,$j,1);
+ $j--;
+ }
+ }
+ }
+ }
+ $Verbose=1;
+
+ print "Detect differing numbers of arguments: $checknumber\n";
+ print "Detect differing return types: $checkreturn\n";
+ print "Detect differing argument types if one is ...: $checketc\n";
+ print "Detect differing numbers of arguments if ... is involved: $checknumberetc\n";
+ print "Detect differing numbers of arguments if ... is involved #2: $checketcnumber\n";
+ print "Detect differing argument types: $checkargtypes\n";
+ print "Detect differing argument types if first has no defined args: $checkargsnil\n";
+ print "Detect differing argument types if second has no defined args: $checknilargs\n";
+ print "Detect differing argument types if first has only ...: $checkargsniletc\n";
+ print "Detect differing argument types if second has only ...: $checkniletcargs\n";
+ print "Detect differing argument types by constness: $checkconst\n";
+ print "Detect differing argument types by signedness: $checksign\n";
+ print "Detect differing return types if one is not defined: $checkreturnnil\n";
+ print "Types known: ",join(",", at types),"\n";
+
+ }
+
+ my($function, at headers) = @_;
+ @headers = CheckHSymbol($function, at headers);
+ return undef if !@headers;
+
+ my $rettype = undef;
+ my @args = ();
+ my @validcount = ();
+
+ # Can we check the return type without worry about arguements?
+ if($checkreturn and (!$checknilargs or !$checkniletcargs)) {
+ for (@types) {
+ if(ApplyHeaders("extern $_ $function(". ($checknilargs?"...":"").");main(){}",[@headers])) {
+ $rettype = $_; # Great, we found the return type.
+ last;
+ }
+ }
+ }
+
+ if(!defined($rettype) and $checkreturnnil) {
+ die "No way to deduce function prototype in a rational amount of time";
+ }
+
+ my $numargs=-1;
+ my $varargs=0;
+ for (0..32) {
+ if(ApplyHeaders("main(){ $function(".join(",",("0") x $_).");}", at headers)) {
+ $numargs=$_;
+ if(ApplyHeaders("main(){ $function(".join(",",("0") x ($_+1)).");}", at headers)) {
+ $varargs=1;
+ }
+ last
+ }
+ }
+
+ die "Unable to deduce number of arguments" if $numargs==-1;
+
+ if($varargs) { $args[$numargs]="..."; }
+
+ # OK, now we know how many arguments the thing takes.
+
+
+ if(@args>0 and !defined($rettype)) {
+ for (@types) {
+ if(defined(ApplyHeaders("extern $_ $function(".join(",", at args).");main(){}",[@headers]))) {
+ $rettype = $_; # Great, we found the return type.
+ last;
+ }
+ }
+ }
+
+ print "Return type: $rettype\nArguments: ",join(",", at args),"\n";
+ print "Valid number of arguments: $numargs\n";
+ print "Accepts variable number of args: $varargs\n";
+}
+
+
+#$Verbose=1;
+
+#print scalar(join("|",CheckHeader("sgtty.h"))),"\n";
+#print scalar(join("|",FindHeader(CheckHeader("sgtty.h")))),"\n";
+#print scalar(join("|",CheckSymbol("COLOR_PAIRS","curses.h","-lcurses","ncurses.h","-lncurses","ncurses/ncurses.h","ncurses/libncurses.a"))),"\n";
+#print scalar(join("|",GetNumericSymbol("PRIO_USER","sys/resource.h",""))),"\n";
+
Added: packages/libterm-readkey-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/MANIFEST 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/MANIFEST 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,9 @@
+Configure.pm
+MANIFEST
+Makefile.PL
+README
+ReadKey.pm
+ReadKey.xs
+genchars.pl
+ppport.h
+test.pl
Added: packages/libterm-readkey-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/Makefile.PL 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/Makefile.PL 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,61 @@
+# Term::ReadKey Makefile.PL Version 2.18
+# $Id: Makefile.PL,v 1.3 2002/01/28 18:40:18 gellyfish Exp $
+
+use ExtUtils::MakeMaker;
+use Carp;
+
+my $mm_version = $ExtUtils::MakeMaker::VERSION || $ExtUtils::MakeMaker::Version;
+if( $mm_version < 3.5 ) {
+ croak("Sorry, but MakeMaker 3.5 or better is needed to build this package.");
+}
+
+&WriteMakefile(
+ NAME => 'Term::ReadKey',
+ DISTNAME => 'TermReadKey',
+ VERSION_FROM => 'ReadKey.pm',
+ XSPROTOARG => '-noprototypes',
+ PM => { "ReadKey.pm" => '$(INST_LIBDIR)/ReadKey.pm'},
+
+ 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" },
+
+# Uncomment these to allow testing of sgtty under Linux. Not needed normally.
+# INC => "-I/usr/include/bsd",
+# LIBS => "-lbsd"
+);
+
+sub MY::realclean {
+ my $self = shift;
+ $_ = $self->MM::realclean();
+ s/\t/\trm -f cchars.h\n\t/;
+ $_;
+}
+
+sub MY::top_targets {
+ my $self = shift;
+ $_ = $self->MM::top_targets();
+ $_ .= "
+
+sgtty cchars.h: genchars.pl
+ \$(PERL) -I\$(PERL_LIB) genchars.pl
+
+distcc: genchars.pl
+ \$(PERL) -I\$(PERL_LIB) genchars.pl dist
+
+ReadKey.c: cchars.h
+
+";
+ $_;
+
+}
+
+sub MY::test {
+ my $self = shift;
+ $_ = $self->MM::test();
+ s/test.pl/-w test.pl/;
+ $_;
+}
+
+sub MY::test_interactive
+{
+ return "Fooo";
+}
Added: packages/libterm-readkey-perl/branches/upstream/current/README
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/README 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/README 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,125 @@
+ Term::ReadKey 2.21 - Change terminal modes, and perform non-blocking reads.
+
+ Copyright (C) 1994-1999 Kenneth Albanowski.
+ 2001,2002 Jonathan Stowe
+
+ Unlimited distribution and/or modification is allowed as long as this
+ copyright notice remains intact.
+
+This module, ReadKey, provides ioctl control for terminals and Win32
+consoles so the input modes can be changed (thus allowing reads of a single
+character at a time), and also provides non-blocking reads of stdin, as well
+as several other terminal related features, including retrieval/modification
+of the screen size, and retrieval/modification of the control characters.
+Installation requires MakeMaker 3.5 or higher (MakeMaker 3.7 is included
+with perl 5.001, so now is a good time to upgrade if you haven't already.)
+
+To install, unpack somewhere, type "perl Makefile.PL", and then "make test".
+If the compilation and the tests are successful, then change to root and run
+"make install".
+
+As of 2.17 the interactive test has been removed as the default for the
+convenience of automated installers, CPAN-Testers and so on. The non
+interactive tests whilst confirming that the module has built correctly
+and has a good chance of working correctly cannot determine whether the
+effect as observed on the screen is correct so you might want to run:
+
+ perl -Mblib test.pl interactive
+
+before you run 'make install'.
+
+Also from 2.17 this module has to provide its own support for compilers
+that can't take function prototypes as with Perl 5.8.0 this last vestige
+of support for non-ANSI compilers will disappear. The requirement for
+an ANSI C compiler has been present since Perl 5.005 so it is likely that
+at some point in the future this module will follow that requirement too.
+If you have any difficulties with older Perl's please contact the maintainer.
+
+The module has support for Win32 since version 2.10. Version 2.17 has been
+tested with ActivePerl build 623 and Visual Studio 6 and found to work
+as expected, but do not be surprised if it fails with another compiler
+or distribution. There are some limitations, with the ReadLine call
+being unavailable, and ReadKey possibly generating bad results if you
+are reading from multiple consoles, and key repeat is used. For Win32
+users without a C compiler there is a precompiled version of this module
+available as a package for ActivePerl, it is probably a few versions
+behind the latest release but has been reported to work well.
+
+VERY IMPORTANT: In 2.00, the ReadKey/ReadLine arguments changed. Now, if
+you want a call that is non-blocking and returns immediately if no
+character is waiting, please call it with -1, instead of 1. Positive
+arguments now indicate a timeout, so 1 would wait a second before timing
+out.
+
+As older versions will accept -1, it is reccomended to change all code
+that uses ReadMode.
+
+
+The terminal mode function is controlled by the "ReadMode" function, which
+takes a single numeric argument, and an optional filehandle. This argument
+should be one of the following:
+
+ 0: (Reset) Restore original settings.
+
+ 1: (Cooked) Change to what is commonly the default mode, echo on,
+ buffered, signals enabled, Xon/Xoff possibly enabled, and 8-bit mode
+ possibly disabled.
+
+ 2: (Cooked-Invisible) Same as 1, just with echo off. Nice for reading
+ passwords.
+
+ 3: (CBreak) Echo off, unbuffered, signals enabled, Xon/Xoff possibly
+ enabled, and 8-bit mode possibly enabled.
+
+ 4: (Raw) Echo off, unbuffered, signals disabled, Xon/Xoff disabled,
+ and 8-bit mode possibly disabled.
+
+ 5: (Really-Raw) Echo off, unbuffered, signals disabled, Xon/Xoff
+ disabled, 8-bit mode enabled if parity permits, and CR to CR/LF
+ translation turned off.
+
+If you just need to read a key at a time, then modes 3 or 4 are probably
+sufficient. Mode 4 is a tad more flexible, but needs a bit more work to
+control. If you use ReadMode 3, then you should install a SIGINT or END
+handler to reset the terminal (via ReadMode 0) if the user aborts the
+program via ^C. (For any mode, an END handler consisting of "ReadMode 0" is
+actually a good idea.)
+
+Non-blocking support is provided via the ReadKey and ReadLine functions. If
+they are passed no argument, or an argument of zero, they will act like a
+normal getc(STDIN) or scalar(<STDIN>). If they are passed a negative
+argument, then they will immediatly return undef if no input is present. If
+passed a positive argument, then they will wait until that time in seconds
+has passed before returning undef. In most situations, you will probably
+want to use "ReadKey -1".
+
+Note that a non-blocking ReadLine probably won't do what you expect,
+although it is perfectly predictable, and that the ReadMode will have to be
+1 or 0 for it to make sense at all.
+
+A routine is also provided to get the current terminal size,
+"GetTerminalSize". This will either return a four value array containing the
+width and height of the screen in characters and then in pixels, or nothing
+( if the OS can't return that info). SetTerminalSize allows the stored
+settings to be modified. Note that this does _not_ change the physical size
+of the screen, it will only change the size reported by GetTerminalSize, and
+other programs that check the terminal size in the same manner.
+
+GetControlChars returns a hash containing all of the valid control
+characters, such as ("INTERRUPT" => "\x3", etc.). SetControlChars takes an
+array (or a hash) as a parameter that should consist of similar name/value
+pairs and will modify the control character settings.
+
+Note that it is entirely possible that there are portability problems with
+the routines in ReadKey.xs. If you find any problems, including compilation
+failures, or control characters not supported by Set/GetControlChars,
+_please_ tell me about them, by mailing the maintainer at jns at gellyfish.com,
+ or lastly contacting perl5-porters at perl.org. Any problems
+will get fixed if at all possible, but that's not going to happen if I don't
+know about them.
+
+Oh, you may also be interested in the Configure.pm module. It provides tools
+to make porting stuff easier -- calling the compiler, finding headers, etc.
+It contains documentation inside it, and you are welcome to use it in your
+own modules. If you make use of it, I'd be grateful for a message sent to
+the above address.
Added: packages/libterm-readkey-perl/branches/upstream/current/ReadKey.pm
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/ReadKey.pm 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/ReadKey.pm 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,544 @@
+#
+# $Id: ReadKey.pm,v 1.7 2002/07/28 12:01:18 gellyfish Exp $
+#
+
+=head1 NAME
+
+Term::ReadKey - A perl module for simple terminal control
+
+=head1 SYNOPSIS
+
+ use Term::ReadKey;
+ ReadMode 4; # Turn off controls keys
+ while (not defined ($key = ReadKey(-1)) {
+ # No key yet
+ }
+ print "Get key $key\n";
+ ReadMode 0; # Reset tty mode before exiting
+
+=head1 DESCRIPTION
+
+Term::ReadKey is a compiled perl module dedicated to providing simple
+control over terminal driver modes (cbreak, raw, cooked, etc.,) support for
+non-blocking reads, if the architecture allows, and some generalized handy
+functions for working with terminals. One of the main goals is to have the
+functions as portable as possible, so you can just plug in "use
+Term::ReadKey" on any architecture and have a good likelyhood of it working.
+
+=over 8
+
+=item ReadMode MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Restore original settings.
+ 1 Change to cooked mode.
+ 2 Change to cooked mode with echo off.
+ (Good for passwords)
+ 3 Change to cbreak mode.
+ 4 Change to raw mode.
+ 5 Change to ultra-raw mode.
+ (LF to CR/LF translation turned off)
+
+ Or, you may use the synonyms:
+
+ restore
+ normal
+ noecho
+ cbreak
+ raw
+ ultra-raw
+
+These functions are automatically applied to the STDIN handle if no
+other handle is supplied. Modes 0 and 5 have some special properties
+worth mentioning: not only will mode 0 restore original settings, but it
+cause the next ReadMode call to save a new set of default settings. Mode
+5 is similar to mode 4, except no CR/LF translation is performed, and if
+possible, parity will be disabled (only if not being used by the terminal,
+however. It is no different from mode 4 under Windows.)
+
+If you are executing another program that may be changing the terminal mode,
+you will either want to say
+
+ ReadMode 1
+ system('someprogram');
+ ReadMode 1;
+
+which resets the settings after the program has run, or:
+
+ $somemode=1;
+ ReadMode 0;
+ system('someprogram');
+ ReadMode 1;
+
+which records any changes the program may have made, before resetting the
+mode.
+
+=item ReadKey MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using getc
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+(If the filehandle is not supplied, it will default to STDIN.) If there is
+nothing waiting in the buffer during a non-blocked read, then undef will be
+returned. Note that if the OS does not provide any known mechanism for
+non-blocking reads, then a C<ReadKey -1> can die with a fatal error. This
+will hopefully not be common.
+
+If MODE is greater then zero, then ReadKey will use it as a timeout value in
+seconds (fractional seconds are allowed), and won't return C<undef> until
+that time expires. (Note, again, that some OS's may not support this timeout
+behaviour.) If MODE is less then zero, then this is treated as a timeout
+of zero, and thus will return immediately if no character is waiting. A MODE
+of zero, however, will act like a normal getc.
+
+There are currently some limitations with this call under Windows. It may be
+possible that non-blocking reads will fail when reading repeating keys from
+more then one console.
+
+=item ReadLine MODE [, Filehandle]
+
+Takes an integer argument, which can currently be one of the following
+values:
+
+ 0 Perform a normal read using scalar(<FileHandle>)
+ -1 Perform a non-blocked read
+ >0 Perform a timed read
+
+If there is nothing waiting in the buffer during a non-blocked read, then
+undef will be returned. Note that if the OS does not provide any known
+mechanism for non-blocking reads, then a C<ReadLine 1> can die with a fatal
+error. This will hopefully not be common. Note that a non-blocking test is
+only performed for the first character in the line, not the entire line.
+This call will probably B<not> do what you assume, especially with
+ReadMode's higher then 1. For example, pressing Space and then Backspace
+would appear to leave you where you started, but any timeouts would now
+be suspended.
+
+This call is currently not available under Windows.
+
+=item GetTerminalSize [Filehandle]
+
+Returns either an empty array if this operation is unsupported, or a four
+element array containing: the width of the terminal in characters, the
+height of the terminal in character, the width in pixels, and the height in
+pixels. (The pixel size will only be valid in some environments.)
+
+Under Windows, this function must be called with an "output" filehandle,
+such as STDOUT, or a handle opened to CONOUT$.
+
+=item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle]
+
+Return -1 on failure, 0 otherwise. Note that this terminal size is only for
+B<informative> value, and changing the size via this mechanism will B<not>
+change the size of the screen. For example, XTerm uses a call like this when
+it resizes the screen. If any of the new measurements vary from the old, the
+OS will probably send a SIGWINCH signal to anything reading that tty or pty.
+
+This call does not work under Windows.
+
+=item GetSpeeds [, Filehandle]
+
+Returns either an empty array if the operation is unsupported, or a two
+value array containing the terminal in and out speeds, in B<decimal>. E.g,
+an in speed of 9600 baud and an out speed of 4800 baud would be returned as
+(9600,4800). Note that currently the in and out speeds will always be
+identical in some OS's. No speeds are reported under Windows.
+
+=item GetControlChars [, Filehandle]
+
+Returns an array containing key/value pairs suitable for a hash. The pairs
+consist of a key, the name of the control character/signal, and the value
+of that character, as a single character. This call does nothing under Windows.
+
+Each key will be an entry from the following list:
+
+ DISCARD
+ DSUSPEND
+ EOF
+ EOL
+ EOL2
+ ERASE
+ ERASEWORD
+ INTERRUPT
+ KILL
+ MIN
+ QUIT
+ QUOTENEXT
+ REPRINT
+ START
+ STATUS
+ STOP
+ SUSPEND
+ SWITCH
+ TIME
+
+Thus, the following will always return the current interrupt character,
+regardless of platform.
+
+ %keys = GetControlChars;
+ $int = $keys{INTERRUPT};
+
+=item SetControlChars [, Filehandle]
+
+Takes an array containing key/value pairs, as a hash will produce. The pairs
+should consist of a key that is the name of a legal control
+character/signal, and the value should be either a single character, or a
+number in the range 0-255. SetControlChars will die with a runtime error if
+an invalid character name is passed or there is an error changing the
+settings. The list of valid names is easily available via
+
+ %cchars = GetControlChars();
+ @cnames = keys %cchars;
+
+This call does nothing under Windows.
+
+=back
+
+=head1 AUTHOR
+
+Kenneth Albanowski <kjahds at kjahds.com>
+
+Currently maintained by Jonathan Stowe <jns at gellyfish.com>
+
+=cut
+
+package Term::ReadKey;
+
+
+$VERSION = '2.21';
+
+require Exporter;
+require AutoLoader;
+require DynaLoader;
+use Carp;
+
+ at ISA = qw(Exporter AutoLoader DynaLoader);
+
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+
+ at EXPORT = qw(
+ ReadKey
+ ReadMode
+ ReadLine
+ GetTerminalSize
+ SetTerminalSize
+ GetSpeed
+ GetControlChars
+ SetControlChars
+ );
+
+
+ at EXPORT_OK = qw();
+
+bootstrap Term::ReadKey;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+
+# Should we use LINES and COLUMNS to try and get the terminal size?
+# Change this to zero if you have systems where these are commonly
+# set to erroneous values. (But if either are nero zero, they won't be
+# used anyhow.)
+
+$UseEnv = 1;
+
+
+%modes=( original => 0,
+ restore => 0,
+ normal => 1,
+ noecho => 2,
+ cbreak => 3,
+ raw => 4,
+ 'ultra-raw' => 5);
+
+sub ReadMode {
+ my($mode) = $modes{$_[0]};
+ my($fh) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined($mode))
+ { SetReadMode($mode,$fh) }
+ elsif( $_[0] =~ /^\d/)
+ { SetReadMode($_[0],$fh) }
+ else
+ { croak("Unknown terminal mode `$_[0]'"); }
+}
+
+sub normalizehandle {
+ my($file) = @_;
+# print "Handle = $file\n";
+ if(ref($file)) { return $file; } # Reference is fine
+# if($file =~ /^\*/) { return $file; } # Type glob is good
+ if (ref(\$file) eq 'GLOB') { return $file; } # Glob is good
+# print "Caller = ",(caller(1))[0],"\n";
+ return \*{((caller(1))[0])."::$file"};
+}
+
+
+sub GetTerminalSize {
+ my($file) = normalizehandle((@_>1?$_[1]:\*STDOUT));
+ my(@results) = ();
+ my(@fail);
+
+ if(&termsizeoptions() & 1) # VIO
+ {
+ @results = GetTermSizeVIO($file);
+ push(@fail,"VIOGetMode call");
+ } elsif(&termsizeoptions() & 2) # GWINSZ
+ {
+ @results = GetTermSizeGWINSZ($file);
+ push(@fail,"TIOCGWINSZ ioctl");
+ } elsif(&termsizeoptions() & 4) # GSIZE
+ {
+ @results = GetTermSizeGSIZE($file);
+ push(@fail,"TIOCGSIZE ioctl");
+ } elsif(&termsizeoptions() & 8) # WIN32
+ {
+ @results = GetTermSizeWin32($file);
+ push(@fail,"Win32 GetConsoleScreenBufferInfo call");
+ } else
+ {
+ @results = ();
+ }
+
+ if(@results<4 and $UseEnv) {
+ my($C) = defined($ENV{COLUMNS}) ? $ENV{COLUMNS} : 0;
+ my($L) = defined($ENV{LINES}) ? $ENV{LINES} : 0;
+ if(($C >= 2) and ($L >=2)) {
+ @results = ($C+0,$L+0,0,0);
+ }
+ push(@fail,"COLUMNS and LINES environment variables");
+ }
+
+ if(@results<4) {
+ my($prog) = "resize";
+
+ # Workaround for Solaris path sillyness
+ if(-f "/usr/openwin/bin/resize") { $prog = "/usr/openwin/bin/resize"}
+
+ my($resize) = scalar(`$prog 2>/dev/null`);
+ if(defined $resize and ($resize =~ /COLUMNS\s*=\s*(\d+)/ or
+ $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/)) {
+ $results[0] = $1;
+ if( $resize =~ /LINES\s*=\s*(\d+)/ or
+ $resize =~ /setenv\s+LINES\s+'?(\d+)/) {
+ $results[1] = $1;
+ @results[2,3] = (0,0);
+ } else {
+ @results = ();
+ }
+ } else {
+ @results = ();
+ }
+ push(@fail,"resize program");
+ }
+
+ if(@results<4) {
+ die "Unable to get Terminal Size.".join("", map(" The $_ didn't work.", at fail));
+ }
+
+ @results;
+}
+
+
+
+if(&blockoptions() & 1) # Use nodelay
+{
+ if(&blockoptions() & 2) #poll
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1);
+ }
+ my ($value) = getc $File;
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,0);
+ }
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+
+ if (defined $_[0] && $_[0] > 0) {
+ if ($_[0]) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ }
+ if (defined $_[0] && $_[0] < 0) {
+ &setnodelay($File,1)
+ };
+ my ($value) = scalar(<$File>);
+ if ( defined $_[0] && $_[0]<0 ) {
+ &setnodelay($File,0)
+ };
+ $value;
+ }
+DONE
+ }
+ elsif(&blockoptions() & 4) #select
+ {
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ if($_[0]) {return undef if &selectfile($File,$_[0])==0}
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ } else { #nothing
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = getc $File;
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1);}
+ my($value) = getc $File;
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0);}
+ $value;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]>0) {
+ # Nothing better seems to exist, so I just use time-of-day
+ # to timeout the read. This isn't very exact, though.
+ $starttime=time;
+ $endtime=$starttime+$_[0];
+ &setnodelay($File,1);
+ my($value)=undef;
+ while(time<$endtime) { # This won't catch wraparound!
+ $value = scalar(<$File>);
+ last if defined($value);
+ }
+ &setnodelay($File,0);
+ return $value;
+ }
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,1)};
+ my($value)=scalar(<$File>);
+ if(defined $_[0] && $_[0]<0) {&setnodelay($File,0)};
+ $value;
+ }
+DONE
+ }
+}
+elsif(&blockoptions() & 2) # Use poll
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &pollfile($File,$_[0]) == 0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0]!=0) {
+ return undef if &pollfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif(&blockoptions() & 4) # Use select
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] !=0 ) {
+ return undef if &selectfile($File,$_[0])==0
+ }
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if(defined $_[0] && $_[0] != 0) {
+ return undef if &selectfile($File,$_[0]) == 0;
+ }
+ scalar(<$File>);
+ }
+DONE
+}
+elsif(&blockoptions() & 8) # Use Win32
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if ($_[0]) {
+ Win32PeekChar($File, $_[0]);
+ } else {
+ getc $File;
+ }
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])};
+ #scalar(<$File>);
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+else
+{
+ eval <<'DONE';
+ sub ReadKey {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadKey is not supported on this architecture")}
+ getc $File;
+ }
+ sub ReadLine {
+ my($File) = normalizehandle((@_>1?$_[1]:\*STDIN));
+ if($_[0])
+ {croak("Non-blocking ReadLine is not supported on this architecture")}
+ scalar(<$File>);
+ }
+DONE
+}
+
+package Term::ReadKey; # return to package ReadKey so AutoSplit is happy
+1;
+
+__END__;
Added: packages/libterm-readkey-perl/branches/upstream/current/ReadKey.xs
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/ReadKey.xs 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/ReadKey.xs 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,1824 @@
+/* -*-C-*- */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+
+#define InputStream PerlIO *
+
+/*******************************************************************
+
+ Copyright (C) 1994,1995,1996,1997 Kenneth Albanowski. Unlimited
+ distribution and/or modification is allowed as long as this copyright
+ notice remains intact.
+
+ Written by Kenneth Albanowski on Thu Oct 6 11:42:20 EDT 1994
+ Contact at kjahds at kjahds.com or CIS:70705,126
+
+ Maintained by Jonathan Stowe <jns at gellyfish.com>
+
+ $Id: ReadKey.xs,v 1.8 2002/07/28 12:01:18 gellyfish Exp $
+
+ Version 2.21, Sun Jul 28 12:57:56 BST 2002
+ Fix to improve the chances of automated testing succeeding
+
+ Version 2.20, Tue May 21 07:52:47 BST 2002
+ Patch from Autrijus Tang fixing Win32 Breakage with bleadperl
+
+ Version 2.19, Thu Mar 21 07:25:31 GMT 2002
+ Added check for definedness of $_[0] in comparisons in ReadKey, ReadLine
+ after reports of warnings.
+
+ Version 2.18, Sun Feb 10 13:06:57 GMT 2002
+ Altered prototyping style after reports of compile failures on
+ Windows.
+
+ Version 2.17, Fri Jan 25 06:58:47 GMT 2002
+ The '_' macro for non-ANSI compatibility was removed in 5.7.2
+
+ Version 2.16, Thu Nov 29 21:19:03 GMT 2001
+ It appears that the genchars.pl bit of the patch didnt apply
+ Applied the new ppport.h from Devel::PPPort
+
+ Version 2.15, Sun Nov 4 15:02:37 GMT 2001 (jns)
+ Applied the patch in
+ http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-01/msg01588.html
+ for PerlIO compatibility.
+
+ Version 2.14, Sun Mar 28 23:26:13 EST 1999
+ ppport.h 1.007 fixed for 5.005_55.
+
+ Version 2.13, Wed Mar 24 20:46:06 EST 1999
+ Adapted to ppport.h 1.006.
+
+ Version 2.12, Wed Jan 7 10:33:11 EST 1998
+ Slightly modified test and error reporting for Win32.
+
+ Version 2.11, Sun Dec 14 00:39:12 EST 1997
+ First attempt at Win32 support.
+
+ Version 2.10, skipped
+
+ Version 2.09, Tue Oct 7 13:07:43 EDT 1997
+ Grr. Added explicit detection of sys/poll.h and poll.h.
+
+ Version 2.08, Mon Oct 6 16:07:44 EDT 1997
+ Changed poll.h to sys/poll.h.
+
+ Version 2.07, Sun Jan 26 19:11:56 EST 1997
+ Added $VERSION to .pm.
+
+ Version 2.06, Tue Nov 26 01:47:09 EST 1996
+ Added PERLIO support and removed duplicate declaration in .pm.
+
+ Version 2.05, Tue Mar 12 19:08:33 EST 1996
+ Changed poll support so it works. Cleaned up .pm a little.
+
+ Version 2.04, Tue Oct 10 05:35:48 EDT 1995
+ Whoops. Changed GetTermSize back so that GSIZE code won't be
+ compiled if GWINSZ is being used. Also took ts_xxx and ts_yyy
+ out of GSIZE.
+
+ Version 2.03, Thu Sep 21 21:53:16 EDT 1995
+ Fixed up debugging info in Readkey.pm, and changed TermSizeVIO
+ to use _scrsize(). Hopefully this is GO for both Solaris and OS/2.
+
+ Version 2.02, Mon Sep 18 22:17:57 EDT 1995
+ Workaround for Solaris bug wasn't sufficient. Modularlized
+ GetTermSize into perl code, and added support for the
+ `resize` executable. Hard coded path for Solaris machines.
+
+ Version 2.01, Wed Sep 13 22:22:23 EDT 1995
+ Change error reporting around in getscreensize so that if
+ an ioctl fails but getenv succeeds, no warning will be
+ printed. This is an attempt to work around a Solaris bug where
+ TIOCGWINSZ fails in telnet sessions.
+
+ Version 2.00, Mon Sep 4 06:37:24 EDT 1995
+ Added timeouts to select/poll, added USE_STDIO_PTR support
+ (required for recent perl revisions), and fixed up compilation
+ under OS/2.
+
+ Version 1.99, Fri Aug 11 20:18:11 EDT 1995
+ Add file handles to ReadMode.
+
+ Version 1.97, Mon Apr 10 21:41:52 EDT 1995
+ Changed mode 5 to disable UC & delays. Added more ECHO flags.
+ Tested termio[s] & sgtty.
+ Added termoptions so test.pl can give more info.
+
+ Version 1.96,
+ Mucked with filehandle selection in ReadKey.pm.
+
+ Version 1.95,
+ Cleaning up for distribution.
+
+ Version 1.94,
+ Dealt with get/settermsize sillyness.
+
+ Version 1.91, Sat Mar 11 23:47:04 EST 1995:
+ Andy's patches, and a bit of termsize finesse.
+
+ Version 1.9, Thu Mar 9 14:11:49 EST 1995:
+ Modifying for portability. Prototypes, singed chars, etc.
+
+ Version 1.8, Mon Jan 9 23:18:14 EST 1995:
+ Added use of Configure.pm. No changes to ReadKey.
+
+ Version 1.7, Fri Dec 16 13:48:14 EST 1994:
+ Getting closer to release. Added new readmode 2. Had to bump up other
+ modes, unfortunately. This is the _last_ time I do that. If I have to
+ bump up the modes again, I'm switching to a different scheme.
+
+ Version 1.6, Wed Dec 14 17:36:59 EST 1994:
+ Completly reorganized the control-char support (twice!) so that
+ it is automatically ported by the preproccessor for termio[s], or
+ by an included script for sgtty. Logical defaults for sgtty are included
+ too. Added Sun TermSize support. (Hope I got it right.)
+
+ Version 1.5, Fri Dec 9 16:07:49 EST 1994:
+ Added SetTermSize, GetSpeeds, Get/SetControlChars, PerlIO support.
+
+ Version 1.01, Thu Oct 20 23:32:39 EDT 1994:
+ Added Select_fd_set_t casts to select() call.
+
+ Version 1.0: First "real" release. Everything seems cool.
+
+
+*******************************************************************/
+
+/***
+
+ Things to do:
+
+ Make sure the GetSpeed function is doing it's best to separate ispeed
+ from ospeed.
+
+ Separate the stty stuff from ReadMode, so that stty -a can be easily
+ used, among other things.
+
+***/
+
+
+
+/* Using these defines, you can elide anything you know
+ won't work properly */
+
+/* Methods of doing non-blocking reads */
+
+/*#define DONT_USE_SELECT*/
+/*#define DONT_USE_POLL*/
+/*#define DONT_USE_NODELAY*/
+
+
+/* Terminal I/O packages */
+
+/*#define DONT_USE_TERMIOS*/
+/*#define DONT_USE_TERMIO*/
+/*#define DONT_USE_SGTTY*/
+
+/* IOCTLs that can be used for GetTerminalSize */
+
+/*#define DONT_USE_GWINSZ*/
+/*#define DONT_USE_GSIZE*/
+
+/* IOCTLs that can be used for SetTerminalSize */
+
+/*#define DONT_USE_SWINSZ*/
+/*#define DONT_USE_SSIZE*/
+
+
+/* This bit is for OS/2 */
+
+#ifdef OS2
+# define I_FCNTL
+# define HAS_FCNTL
+
+# define O_NODELAY O_NDELAY
+
+# define DONT_USE_SELECT
+# define DONT_USE_POLL
+
+# define DONT_USE_TERMIO
+# define DONT_USE_SGTTY
+# define I_TERMIOS
+# define CC_TERMIOS
+
+# define INCL_SUB
+# define INCL_DOS
+
+# include <os2.h>
+# include <stdlib.h>
+
+# define VIOMODE
+#else
+ /* no os2 */
+#endif
+
+/* This bit is for Windows 95/NT */
+
+#ifdef WIN32
+# define DONT_USE_TERMIO
+# define DONT_USE_TERMIOS
+# define DONT_USE_SGTTY
+# define DONT_USE_POLL
+# define DONT_USE_SELECT
+# define DONT_USE_NODELAY
+# define USE_WIN32
+# include <io.h>
+# if defined(_get_osfhandle) && (PERL_VERSION == 4) && (PERL_SUBVERSION < 5)
+# undef _get_osfhandle
+# if defined(_MSC_VER)
+# define level _cnt
+# endif
+# endif
+#endif
+
+/* This bit for NeXT */
+
+#ifdef _NEXT_SOURCE
+ /* fcntl with O_NDELAY (FNDELAY, actually) is broken on NeXT */
+# define DONT_USE_NODELAY
+#endif
+
+#if !defined(DONT_USE_NODELAY)
+# ifdef HAS_FCNTL
+# define Have_nodelay
+# ifdef I_FCNTL
+# include <fcntl.h>
+# endif
+# ifdef I_SYS_FILE
+# include <sys/file.h>
+# endif
+# ifdef I_UNISTD
+# include <unistd.h>
+# endif
+
+/* If any other headers are needed for fcntl or O_NODELAY, they need to get
+ included right here */
+
+# if !defined(O_NODELAY)
+# if !defined(FNDELAY)
+# undef Have_nodelay
+# else
+# define O_NODELAY FNDELAY
+# endif
+# else
+# define O_NODELAY O_NDELAY
+# endif
+# endif
+#endif
+
+#if !defined(DONT_USE_SELECT)
+# ifdef HAS_SELECT
+# ifdef I_SYS_SELECT
+# include <sys/select.h>
+# endif
+
+/* If any other headers are likely to be needed for select, they need to be
+ included right here */
+
+# define Have_select
+# endif
+#endif
+
+#if !defined(DONT_USE_POLL)
+# ifdef HAS_POLL
+# ifdef HAVE_POLL_H
+# include <poll.h>
+# define Have_poll
+# endif
+# ifdef HAVE_SYS_POLL_H
+# include <sys/poll.h>
+# define Have_poll
+# endif
+# endif
+#endif
+
+#ifdef DONT_USE_TERMIOS
+# ifdef I_TERMIOS
+# undef I_TERMIOS
+# endif
+#endif
+#ifdef DONT_USE_TERMIO
+# ifdef I_TERMIO
+# undef I_TERMIO
+# endif
+#endif
+#ifdef DONT_USE_SGTTY
+# ifdef I_SGTTY
+# undef I_SGTTY
+# endif
+#endif
+
+/* Pre-POSIX SVR3 systems sometimes define struct winsize in
+ sys/ptem.h. However, sys/ptem.h needs a type mblk_t (?) which
+ is defined in <sys/stream.h>.
+ No, Configure (dist3.051) doesn't know how to check for this.
+*/
+#ifdef I_SYS_STREAM
+# include <sys/stream.h>
+#endif
+#ifdef I_SYS_PTEM
+# include <sys/ptem.h>
+#endif
+
+#ifdef I_TERMIOS
+# include <termios.h>
+#else
+# ifdef I_TERMIO
+# include <termio.h>
+# else
+# ifdef I_SGTTY
+# include <sgtty.h>
+# endif
+# endif
+#endif
+
+#ifdef I_TERMIOS
+# define CC_TERMIOS
+#else
+# ifdef I_TERMIO
+# define CC_TERMIO
+# else
+# ifdef I_SGTTY
+# define CC_SGTTY
+# endif
+# endif
+#endif
+
+
+/* Fix up the disappearance of the '_' macro in Perl 5.7.2 */
+
+#ifndef _
+# ifdef CAN_PROTOTYPE
+# define _(args) args
+# else
+# define _(args) ()
+# endif
+#endif
+
+#define DisableFlush (1) /* Should flushing mode changes be enabled?
+ I think not for now. */
+
+
+#define STDIN PerlIO_stdin()
+
+#include "cchars.h"
+
+
+int GetTermSizeVIO _((PerlIO * file,
+ int * retwidth, int * retheight,
+ int * xpix, int * ypix));
+
+int GetTermSizeGWINSZ _((PerlIO * file,
+ int * retwidth, int * retheight,
+ int * xpix, int * ypix));
+
+int GetTermSizeGSIZE _((PerlIO * file,
+ int * retwidth, int * retheight,
+ int * xpix, int * ypix));
+
+int GetTermSizeWin32 _((PerlIO * file,
+ int * retwidth, int * retheight,
+ int * xpix, int * ypix));
+
+int SetTerminalSize _((PerlIO * file,
+ int width, int height,
+ int xpix, int ypix));
+
+void ReadMode _((PerlIO * file,int mode));
+
+int pollfile _((PerlIO * file, double delay));
+
+int setnodelay _((PerlIO * file, int mode));
+
+int selectfile _((PerlIO * file, double delay));
+
+int Win32PeekChar _((PerlIO * file, double delay, char * key));
+
+int getspeed _((PerlIO * file, I32 *in, I32 * out ));
+
+
+#ifdef VIOMODE
+int GetTermSizeVIO(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ /*int handle=PerlIO_fileno(file);
+
+ static VIOMODEINFO *modeinfo = NULL;
+
+ if (modeinfo == NULL)
+ modeinfo = (VIOMODEINFO *)malloc(sizeof(VIOMODEINFO));
+
+ VioGetMode(modeinfo,0);
+ *retheight = modeinfo->row ?: 25;
+ *retwidth = modeinfo->col ?: 80;*/
+ int buf[2];
+
+ _scrsize(&buf[0]);
+
+ *retwidth = buf[0]; *retheight = buf[1];
+
+ *xpix = *ypix = 0;
+ return 0;
+}
+#else
+int GetTermSizeVIO(PerlIO *file,int * retwidth,int *retheight, int *xpix,int *ypix)
+{
+ croak("TermSizeVIO is not implemented on this architecture");
+ return 0;
+}
+#endif
+
+
+#if defined(TIOCGWINSZ) && !defined(DONT_USE_GWINSZ)
+int GetTermSizeGWINSZ(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ int handle=PerlIO_fileno(file);
+ struct winsize w;
+
+ if (ioctl (handle, TIOCGWINSZ, &w) == 0) {
+ *retwidth=w.ws_col; *retheight=w.ws_row;
+ *xpix=w.ws_xpixel; *ypix=w.ws_ypixel; return 0;
+ }
+ else {
+ return -1; /* failure */
+ }
+
+}
+#else
+int GetTermSizeGWINSZ(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ croak("TermSizeGWINSZ is not implemented on this architecture");
+ return 0;
+}
+#endif
+
+#if (!defined(TIOCGWINSZ) || defined(DONT_USE_GWINSZ)) && (defined(TIOCGSIZE) && !defined(DONT_USE_GSIZE))
+int GetTermSizeGSIZE(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ int handle=PerlIO_fileno(file);
+
+ struct ttysize w;
+
+ if (ioctl (handle, TIOCGSIZE, &w) == 0) {
+ *retwidth=w.ts_cols; *retheight=w.ts_lines;
+ *xpix=0/*w.ts_xxx*/; *ypix=0/*w.ts_yyy*/; return 0;
+ }
+ else {
+ return -1; /* failure */
+ }
+}
+#else
+int GetTermSizeGSIZE(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ croak("TermSizeGSIZE is not implemented on this architecture");
+ return 0;
+}
+#endif
+
+#ifdef USE_WIN32
+int GetTermSizeWin32(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ int handle=PerlIO_fileno(file);
+ HANDLE whnd = (HANDLE)_get_osfhandle(handle);
+ CONSOLE_SCREEN_BUFFER_INFO info;
+
+ if (GetConsoleScreenBufferInfo(whnd, &info)) {
+ /* Logic: return maximum possible screen width, but return
+ only currently selected height */
+ if (retwidth)
+ *retwidth = info.dwMaximumWindowSize.X;
+ /*info.srWindow.Right - info.srWindow.Left;*/
+ if (retheight)
+ *retheight = info.srWindow.Bottom - info.srWindow.Top;
+ if (xpix)
+ *xpix = 0;
+ if (ypix)
+ *ypix = 0;
+ return 0;
+ } else
+ return -1;
+}
+#else
+int GetTermSizeWin32(PerlIO *file,int *retwidth,int *retheight,int *xpix,int *ypix)
+{
+ croak("TermSizeWin32 is not implemented on this architecture");
+ return 0;
+}
+#endif /* USE_WIN32 */
+
+
+int termsizeoptions() {
+ return 0
+#ifdef VIOMODE
+ | 1
+#endif
+#if defined(TIOCGWINSZ) && !defined(DONT_USE_GWINSZ)
+ | 2
+#endif
+#if defined(TIOCGSIZE) && !defined(DONT_USE_GSIZE)
+ | 4
+#endif
+#if defined(USE_WIN32)
+ | 8
+#endif
+ ;
+}
+
+
+int SetTerminalSize(PerlIO *file,int width,int height,int xpix,int ypix)
+{
+ char buffer[10];
+ int handle=PerlIO_fileno(file);
+
+#ifdef VIOMODE
+ return -1;
+#else
+
+#if defined(TIOCSWINSZ) && !defined(DONT_USE_SWINSZ)
+ struct winsize w;
+
+ w.ws_col=width;
+ w.ws_row=height;
+ w.ws_xpixel=xpix;
+ w.ws_ypixel=ypix;
+ if (ioctl (handle, TIOCSWINSZ, &w) == 0) {
+ sprintf(buffer,"%d",width); /* Be polite to our children */
+ my_setenv("COLUMNS",buffer);
+ sprintf(buffer,"%d",height);
+ my_setenv("LINES",buffer);
+ return 0;
+ }
+ else {
+ croak("TIOCSWINSZ ioctl call to set terminal size failed: %s",Strerror(errno));
+ return -1;
+ }
+#else
+# if defined(TIOCSSIZE) && !defined(DONT_USE_SSIZE)
+ struct ttysize w;
+
+ w.ts_lines=height;
+ w.ts_cols=width;
+ w.ts_xxx=xpix;
+ w.ts_yyy=ypix;
+ if (ioctl (handle, TIOCSSIZE, &w) == 0) {
+ sprintf(buffer,"%d",width);
+ my_setenv("COLUMNS",buffer);
+ sprintf(buffer,"%d",height);
+ my_setenv("LINES",buffer);
+ return 0;
+ }
+ else {
+ croak("TIOCSSIZE ioctl call to set terminal size failed: %s",Strerror(errno));
+ return -1;
+ }
+# else
+ /*sprintf(buffer,"%d",width) * Should we could do this and then *
+ my_setenv("COLUMNS",buffer) * said we succeeded? *
+ sprintf(buffer,"%d",height);
+ my_setenv("LINES",buffer)*/
+
+ return -1; /* Fail */
+# endif
+#endif
+#endif
+
+}
+
+I32 terminal_speeds[] = {
+#ifdef B50
+ 50, B50,
+#endif
+#ifdef B75
+ 75, B75,
+#endif
+#ifdef B110
+ 110, B110,
+#endif
+#ifdef B134
+ 134, B134,
+#endif
+#ifdef B150
+ 150, B150,
+#endif
+#ifdef B200
+ 200, B200,
+#endif
+#ifdef B300
+ 300, B300,
+#endif
+#ifdef B600
+ 600, B600,
+#endif
+#ifdef B1200
+ 1200, B1200,
+#endif
+#ifdef B1800
+ 1800, B1800,
+#endif
+#ifdef B2400
+ 2400, B2400,
+#endif
+#ifdef B4800
+ 4800, B4800,
+#endif
+#ifdef B9600
+ 9600, B9600,
+#endif
+#ifdef B19200
+ 19200, B19200,
+#endif
+#ifdef B38400
+ 38400, B38400,
+#endif
+#ifdef B57600
+ 57600, B57600,
+#endif
+#ifdef B115200
+ 115200, B115200,
+#endif
+#ifdef EXTA
+ 19200, EXTA,
+#endif
+#ifdef EXTB
+ 38400, EXTB,
+#endif
+#ifdef B0
+ 0, B0,
+#endif
+ -1,-1
+};
+
+int getspeed(PerlIO *file,I32 *in, I32 *out)
+{
+ int handle=PerlIO_fileno(file);
+ int i;
+# ifdef I_TERMIOS
+ /* Posixy stuff */
+
+ struct termios buf;
+ tcgetattr(handle,&buf);
+
+ *in = *out = -1;
+ *in = cfgetispeed(&buf);
+ *out = cfgetospeed(&buf);
+ for(i=0;terminal_speeds[i]!=-1;i+=2) {
+ if(*in == terminal_speeds[i+1])
+ { *in = terminal_speeds[i]; break; }
+ }
+ for(i=0;terminal_speeds[i]!=-1;i+=2) {
+ if(*out == terminal_speeds[i+1])
+ { *out = terminal_speeds[i]; break; }
+ }
+ return 0;
+
+# else
+# ifdef I_TERMIO
+ /* SysV stuff */
+ struct termio buf;
+
+ ioctl(handle,TCGETA,&buf);
+
+ *in=*out=-1;
+ for(i=0;terminal_speeds[i]!=-1;i+=2) {
+ if((buf.c_cflag & CBAUD) == terminal_speeds[i+1])
+ { *in=*out=terminal_speeds[i]; break; }
+ }
+ return 0;
+
+# else
+# ifdef I_SGTTY
+ /* BSD stuff */
+ struct sgttyb buf;
+
+ ioctl(handle,TIOCGETP,&buf);
+
+ *in=*out=-1;
+
+ for(i=0;terminal_speeds[i]!=-1;i+=2)
+ if(buf.sg_ospeed == terminal_speeds[i+1])
+ { *out = terminal_speeds[i]; break; }
+
+ for(i=0;terminal_speeds[i]!=-1;i+=2)
+ if(buf.sg_ispeed == terminal_speeds[i+1])
+ { *in = terminal_speeds[i]; break; }
+
+ return 0;
+
+
+# else
+
+ /* No termio, termios or sgtty. I suppose we can try stty,
+ but it would be nice if you could get a better OS */
+
+ return -1;
+
+# endif
+# endif
+# endif
+}
+
+#ifdef WIN32
+struct tbuffer { DWORD Mode; };
+#else
+#ifdef I_TERMIOS
+#define USE_TERMIOS
+#define tbuffer termios
+#else
+#ifdef I_TERMIO
+#define USE_TERMIO
+#define tbuffer termio
+#else
+#ifdef I_SGTTY
+#define USE_SGTTY
+struct tbuffer {
+ struct sgttyb buf;
+#if defined(TIOCGETC)
+ struct tchars tchar;
+#endif
+#if defined(TIOCGLTC)
+ struct ltchars ltchar;
+#endif
+#if defined(TIOCLGET)
+ int local;
+#endif
+};
+#else
+#define USE_STTY
+struct tbuffer {
+ int dummy;
+};
+#endif
+#endif
+#endif
+#endif
+
+HV * filehash; /* Used to store the original terminal settings for each handle*/
+HV * modehash; /* Used to record the current terminal "mode" for each handle*/
+
+void ReadMode(PerlIO *file,int mode)
+{
+ dTHR;
+ int handle;
+ int firsttime;
+ int oldmode;
+ struct tbuffer work;
+ struct tbuffer savebuf;
+
+
+ handle=PerlIO_fileno(file);
+
+ firsttime=!hv_exists(filehash, (char*)&handle, sizeof(int));
+
+
+# ifdef WIN32
+
+ if (!GetConsoleMode((HANDLE)_get_osfhandle(handle), &work.Mode))
+ croak("GetConsoleMode failed, LastError=|%d|",GetLastError());
+
+# endif /* WIN32 */
+
+# ifdef USE_TERMIOS
+ /* Posixy stuff */
+
+ tcgetattr(handle,&work);
+
+
+
+#endif
+#ifdef USE_TERMIO
+ /* SysV stuff */
+
+ ioctl(handle,TCGETA,&work);
+
+
+#endif
+#ifdef USE_SGTTY
+ /* BSD stuff */
+
+ ioctl(handle,TIOCGETP,&work.buf);
+# if defined(TIOCGETC)
+ ioctl(handle,TIOCGETC,&work.tchar);
+# endif
+# if defined(TIOCLGET)
+ ioctl(handle,TIOCLGET,&work.local);
+# endif
+# if defined(TIOCGLTC)
+ ioctl(handle,TIOCGLTC,&work.ltchar);
+# endif
+
+
+#endif
+
+
+ if(firsttime) {
+ firsttime=0;
+ memcpy((void*)&savebuf,(void*)&work,sizeof(struct tbuffer));
+ if(!hv_store(filehash,(char*)&handle,sizeof(int),
+ newSVpv((char*)&savebuf,sizeof(struct tbuffer)),0))
+ croak("Unable to stash terminal settings.\n");
+ if(!hv_store(modehash,(char*)&handle,sizeof(int),newSViv(0),0))
+ croak("Unable to stash terminal settings.\n");
+ } else {
+ SV ** temp;
+ if(!(temp=hv_fetch(filehash,(char*)&handle,sizeof(int),0)))
+ croak("Unable to retrieve stashed terminal settings.\n");
+ memcpy(&savebuf,SvPV(*temp,PL_na),sizeof(struct tbuffer));
+ if(!(temp=hv_fetch(modehash,(char*)&handle,sizeof(int),0)))
+ croak("Unable to retrieve stashed terminal mode.\n");
+ oldmode=SvIV(*temp);
+ }
+
+#ifdef WIN32
+
+ switch (mode) {
+ case 5:
+ /* Should 5 disable ENABLE_WRAP_AT_EOL_OUTPUT? */
+ case 4:
+ work.Mode &= ~(ENABLE_ECHO_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_LINE_INPUT|ENABLE_PROCESSED_OUTPUT);
+ work.Mode |= 0;
+ break;
+ case 3:
+ work.Mode &= ~(ENABLE_LINE_INPUT|ENABLE_ECHO_INPUT);
+ work.Mode |= ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT;
+ break;
+ case 2:
+ work.Mode &= ~(ENABLE_ECHO_INPUT);
+ work.Mode |= ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT;
+ break;
+ case 1:
+ work.Mode &= ~(0);
+ work.Mode |= ENABLE_ECHO_INPUT|ENABLE_LINE_INPUT|ENABLE_PROCESSED_INPUT|ENABLE_PROCESSED_OUTPUT;
+ break;
+ case 0:
+ work = savebuf;
+ firsttime = 1;
+ break;
+ }
+
+ if (!SetConsoleMode((HANDLE)_get_osfhandle(handle), work.Mode))
+ croak("SetConsoleMode failed, LastError=|%d|",GetLastError());
+
+#endif /* WIN32 */
+
+
+#ifdef USE_TERMIOS
+
+
+/* What, me worry about standards? */
+
+# if !defined (VMIN)
+# define VMIN VEOF
+# endif
+
+# if !defined (VTIME)
+# define VTIME VEOL
+# endif
+
+# if !defined (IXANY)
+# define IXANY (0)
+# endif
+
+#ifndef IEXTEN
+#ifdef IDEFAULT
+#define IEXTEN IDEFAULT
+#endif
+#endif
+
+/* XXX Is ONLCR in POSIX?. The value of '4' seems to be the same for
+ both SysV and Sun, so it's probably rather general, and I'm not
+ aware of a POSIX way to do this otherwise.
+*/
+#ifndef ONLCR
+# define ONLCR 4
+#endif
+
+#ifndef IMAXBEL
+#define IMAXBEL 0
+#endif
+#ifndef ECHOE
+#define ECHOE 0
+#endif
+#ifndef ECHOK
+#define ECHOK 0
+#endif
+#ifndef ECHONL
+#define ECHONL 0
+#endif
+#ifndef ECHOPRT
+#define ECHOPRT 0
+#endif
+#ifndef FLUSHO
+#define FLUSHO 0
+#endif
+#ifndef PENDIN
+#define PENDIN 0
+#endif
+#ifndef ECHOKE
+#define ECHOKE 0
+#endif
+#ifndef ONLCR
+#define ONLCR 0
+#endif
+#ifndef OCRNL
+#define OCRNL 0
+#endif
+#ifndef ONLRET
+#define ONLRET 0
+#endif
+#ifndef IUCLC
+#define IUCLC 0
+#endif
+#ifndef OPOST
+#define OPOST 0
+#endif
+#ifndef OLCUC
+#define OLCUC 0
+#endif
+#ifndef ECHOCTL
+#define ECHOCTL 0
+#endif
+#ifndef XCASE
+#define XCASE 0
+#endif
+#ifndef BRKINT
+#define BRKINT 0
+#endif
+
+
+ if(mode==5) {
+ /*\
+ * Disable everything except parity if needed.
+ \*/
+
+ /* Hopefully, this should put the tty into unbuffered mode
+ with signals and control characters (both posixy and normal)
+ disabled, along with flow control. Echo should be off.
+ CR/LF is not translated, along with 8-bit/parity */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag &= ~(ICANON|ISIG|IEXTEN );
+ work.c_lflag &= ~(ECHO|ECHOE|ECHOK|ECHONL|ECHOCTL);
+ work.c_lflag &= ~(ECHOPRT|ECHOKE|FLUSHO|PENDIN|XCASE);
+ work.c_lflag |= NOFLSH;
+ work.c_iflag &= ~(IXOFF|IXON|IXANY|ICRNL|IMAXBEL|BRKINT);
+
+ if(((work.c_iflag & INPCK) != INPCK) ||
+ ((work.c_cflag & PARENB) != PARENB)) {
+ work.c_iflag &= ~ISTRIP;
+ work.c_iflag |= IGNPAR;
+ work.c_iflag &= ~PARMRK;
+ }
+ work.c_oflag &= ~(OPOST |ONLCR|OCRNL|ONLRET);
+
+ work.c_cc[VTIME] = 0;
+ work.c_cc[VMIN] = 1;
+ }
+ else if(mode==4) {
+ /* Hopefully, this should put the tty into unbuffered mode
+ with signals and control characters (both posixy and normal)
+ disabled, along with flow control. Echo should be off.
+ About the only thing left unchanged is 8-bit/parity */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ /*work.c_iflag = savebuf.c_iflag;*/
+ work.c_lflag &= ~(ICANON | ISIG | IEXTEN | ECHO);
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE);
+ work.c_iflag &= ~(IXON | IXANY | BRKINT);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VTIME] = 0;
+ work.c_cc[VMIN] = 1;
+ }
+ else if(mode==3)
+ {
+ /* This should be an unbuffered mode with signals and control
+ characters enabled, as should be flow control. Echo should
+ still be off */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_iflag = savebuf.c_iflag;
+ work.c_lflag &= ~(ICANON | ECHO);
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE);
+ work.c_lflag |= ISIG | IEXTEN;
+ /*work.c_iflag &= ~(IXON | IXOFF | IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;*/
+ work.c_cc[VTIME] = 0;
+ work.c_cc[VMIN] = 1;
+ }
+ else if(mode==2)
+ {
+ /* This should be an unbuffered mode with signals and control
+ characters enabled, as should be flow control. Echo should
+ still be off */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_iflag = savebuf.c_iflag;
+ work.c_lflag |= ICANON|ISIG|IEXTEN;
+ work.c_lflag &= ~ECHO;
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL|ECHOCTL|ECHOPRT|ECHOKE);
+ /*work.c_iflag &= ~(IXON |IXOFF|IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];*/
+ }
+ else if(mode==1)
+ {
+ /* This should be an unbuffered mode with signals and control
+ characters enabled, as should be flow control. Echo should
+ still be off */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_iflag = savebuf.c_iflag;
+ work.c_lflag |= ICANON|ECHO|ISIG|IEXTEN;
+ /*work.c_iflag &= ~(IXON |IXOFF|IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];*/
+ }
+ else if(mode==0){
+ /*work.c_lflag &= ~BITMASK;
+ work.c_lflag |= savebuf.c_lflag & BITMASK;
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];
+ work.c_iflag = savebuf.c_iflag;
+ work.c_iflag &= ~(IXON|IXOFF|IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);*/
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+ /*Copy(&work,&savebuf,1,sizeof(struct tbuffer));*/
+
+ firsttime=1;
+ }
+ else
+ {
+ croak("ReadMode %d is not implemented on this architecture.",mode);
+ return;
+ }
+
+
+ /* If switching from a "lower power" mode to a higher one, keep the
+ data that may be in the queue, as it can easily be type-ahead. On
+ switching to a lower mode from a higher one, however, flush the queue
+ so that raw keystrokes won't hit an unexpecting program */
+
+ if(DisableFlush || oldmode<=mode)
+ tcsetattr(handle,TCSANOW,&work);
+ else
+ tcsetattr(handle,TCSAFLUSH,&work);
+
+ /*tcsetattr(handle,TCSANOW,&work);*/ /* It might be better to FLUSH
+ when changing gears to a lower mode,
+ and only use NOW for higher modes.
+ */
+
+
+#endif
+#ifdef USE_TERMIO
+
+/* What, me worry about standards? */
+
+# if !defined (IXANY)
+# define IXANY (0)
+# endif
+
+#ifndef ECHOE
+#define ECHOE 0
+#endif
+#ifndef ECHOK
+#define ECHOK 0
+#endif
+#ifndef ECHONL
+#define ECHONL 0
+#endif
+#ifndef XCASE
+#define XCASE 0
+#endif
+#ifndef BRKINT
+#define BRKINT 0
+#endif
+
+
+
+ if(mode==5) {
+ /* This mode should be echo disabled, signals disabled,
+ flow control disabled, and unbuffered. CR/LF translation
+ is off, and 8 bits if possible */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag &= ~(ECHO | ISIG | ICANON | XCASE);
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL);
+ work.c_iflag &= ~(IXON | IXOFF | IXANY | ICRNL | BRKINT);
+ if((work.c_cflag | PARENB)!=PARENB ) {
+ work.c_iflag &= ~(ISTRIP|INPCK);
+ work.c_iflag |= IGNPAR;
+ }
+ work.c_oflag &= ~(OPOST|ONLCR);
+ work.c_cc[VMIN] = 1;
+ work.c_cc[VTIME] = 1;
+ }
+ else if(mode==4) {
+ /* This mode should be echo disabled, signals disabled,
+ flow control disabled, and unbuffered. Parity is not
+ touched. */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag &= ~(ECHO | ISIG | ICANON);
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL);
+ work.c_iflag = savebuf.c_iflag;
+ work.c_iflag &= ~(IXON | IXOFF | IXANY | BRKINT);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VMIN] = 1;
+ work.c_cc[VTIME] = 1;
+ }
+ else if(mode==3) {
+ /* This mode tries to have echo off, signals enabled,
+ flow control as per the original setting, and unbuffered. */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag &= ~(ECHO | ICANON);
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL);
+ work.c_lflag |= ISIG;
+ work.c_iflag = savebuf.c_iflag;
+ work.c_iflag &= ~(IXON | IXOFF | IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VMIN] = 1;
+ work.c_cc[VTIME] = 1;
+ }
+ else if(mode==2) {
+ /* This mode tries to set echo on, signals on, and buffering
+ on, with flow control set to whatever it was originally. */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag |= (ISIG | ICANON);
+ work.c_lflag &= ~ECHO;
+ work.c_lflag &= ~(ECHOE | ECHOK | ECHONL);
+ work.c_iflag = savebuf.c_iflag;
+ work.c_iflag &= ~(IXON | IXOFF | IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];
+
+ /* This assumes turning ECHO and ICANON back on is
+ sufficient to re-enable cooked mode. If this is a
+ problem, complain to me */
+
+ /* What the heck. We're already saving the entire buf, so
+ I'm now going to reset VMIN and VTIME too. Hope this works
+ properly */
+
+ }
+ else if(mode==1) {
+ /* This mode tries to set echo on, signals on, and buffering
+ on, with flow control set to whatever it was originally. */
+
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+
+ work.c_lflag |= (ECHO | ISIG | ICANON);
+ work.c_iflag = savebuf.c_iflag;
+ work.c_iflag &= ~(IXON | IXOFF | IXANY);
+ work.c_iflag |= savebuf.c_iflag & (IXON|IXOFF|IXANY);
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];
+
+ /* This assumes turning ECHO and ICANON back on is
+ sufficient to re-enable cooked mode. If this is a
+ problem, complain to me */
+
+ /* What the heck. We're already saving the entire buf, so
+ I'm now going to reset VMIN and VTIME too. Hope this works
+ properly */
+ }
+ else if(mode==0) {
+ /* Put things back the way they were */
+
+ /*work.c_lflag = savebuf.c_lflag;
+ work.c_iflag = savebuf.c_iflag;
+ work.c_oflag = savebuf.c_oflag;
+ work.c_cc[VMIN] = savebuf.c_cc[VMIN];
+ work.c_cc[VTIME] = savebuf.c_cc[VTIME];*/
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+ firsttime=1;
+ }
+ else
+ {
+ croak("ReadMode %d is not implemented on this architecture.",mode);
+ return;
+ }
+
+
+ if(DisableFlush || oldmode<=mode)
+ ioctl(handle,TCSETA,&work);
+ else
+ ioctl(handle,TCSETAF,&work);
+
+#endif
+#ifdef USE_SGTTY
+
+
+ if(mode==5) {
+ /* Unbuffered, echo off, signals off, flow control off */
+ /* CR-CR/LF mode off too, and 8-bit path enabled. */
+# if defined(TIOCLGET) && defined(LPASS8)
+ if((work.buf.sg_flags & (EVENP|ODDP))==0 ||
+ (work.buf.sg_flags & (EVENP|ODDP))==(EVENP|ODDP))
+ work.local |= LPASS8; /* If parity isn't being used, use 8 bits */
+# endif
+ work.buf.sg_flags &= ~(ECHO|CRMOD);
+ work.buf.sg_flags |= (RAW|CBREAK);
+# if defined(TIOCGETC)
+ work.tchar.t_intrc = -1;
+ work.tchar.t_quitc = -1;
+ work.tchar.t_startc= -1;
+ work.tchar.t_stopc = -1;
+ work.tchar.t_eofc = -1;
+ work.tchar.t_brkc = -1;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar.t_suspc= -1;
+ work.ltchar.t_dsuspc= -1;
+ work.ltchar.t_rprntc= -1;
+ work.ltchar.t_flushc= -1;
+ work.ltchar.t_werasc= -1;
+ work.ltchar.t_lnextc= -1;
+# endif
+ }
+ else if(mode==4) {
+ /* Unbuffered, echo off, signals off, flow control off */
+ work.buf.sg_flags &= ~(ECHO|RAW);
+ work.buf.sg_flags |= (CBREAK|CRMOD);
+# if defined(TIOCLGET)
+ work.local=savebuf.local;
+# endif
+# if defined(TIOCGETC)
+ work.tchar.t_intrc = -1;
+ work.tchar.t_quitc = -1;
+ work.tchar.t_startc= -1;
+ work.tchar.t_stopc = -1;
+ work.tchar.t_eofc = -1;
+ work.tchar.t_brkc = -1;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar.t_suspc= -1;
+ work.ltchar.t_dsuspc= -1;
+ work.ltchar.t_rprntc= -1;
+ work.ltchar.t_flushc= -1;
+ work.ltchar.t_werasc= -1;
+ work.ltchar.t_lnextc= -1;
+# endif
+ }
+ else if(mode==3) {
+ /* Unbuffered, echo off, signals on, flow control on */
+ work.buf.sg_flags &= ~(RAW|ECHO);
+ work.buf.sg_flags |= CBREAK|CRMOD;
+# if defined(TIOCLGET)
+ work.local=savebuf.local;
+# endif
+# if defined(TIOCGLTC)
+ work.tchar = savebuf.tchar;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar = savebuf.ltchar;
+# endif
+ }
+ else if(mode==2) {
+ /* Buffered, echo on, signals on, flow control on */
+ work.buf.sg_flags &= ~(RAW|CBREAK);
+ work.buf.sg_flags |= CRMOD;
+ work.buf.sg_flags &= ~ECHO;
+# if defined(TIOCLGET)
+ work.local=savebuf.local;
+# endif
+# if defined(TIOCGLTC)
+ work.tchar = savebuf.tchar;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar = savebuf.ltchar;
+# endif
+ }
+ else if(mode==1) {
+ /* Buffered, echo on, signals on, flow control on */
+ work.buf.sg_flags &= ~(RAW|CBREAK);
+ work.buf.sg_flags |= ECHO|CRMOD;
+# if defined(TIOCLGET)
+ work.local=savebuf.local;
+# endif
+# if defined(TIOCGLTC)
+ work.tchar = savebuf.tchar;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar = savebuf.ltchar;
+# endif
+ }
+ else if(mode==0){
+ /* Original settings */
+#if 0
+ work.buf.sg_flags &= ~(RAW|CBREAK|ECHO|CRMOD);
+ work.buf.sg_flags |= savebuf.sg_flags & (RAW|CBREAK|ECHO|CRMOD);
+# if defined(TIOCLGET)
+ work.local=savebuf.local;
+# endif
+# if defined(TIOCGLTC)
+ work.tchar = savebuf.tchar;
+# endif
+# if defined(TIOCGLTC)
+ work.ltchar = savebuf.ltchar;
+# endif
+#endif
+ memcpy((void*)&work,(void*)&savebuf,sizeof(struct tbuffer));
+ firsttime=1;
+ }
+ else
+ {
+ croak("ReadMode %d is not implemented on this architecture.",mode);
+ return;
+ }
+#if defined(TIOCLSET)
+ ioctl(handle,TIOCLSET,&work.local);
+#endif
+#if defined(TIOCSETC)
+ ioctl(handle,TIOCSETC,&work.tchar);
+#endif
+# if defined(TIOCGLTC)
+ ioctl(handle,TIOCSLTC,&work.ltchar);
+# endif
+ if(DisableFlush || oldmode<=mode)
+ ioctl(handle,TIOCSETN,&work.buf);
+ else
+ ioctl(handle,TIOCSETP,&work.buf);
+#endif
+#ifdef USE_STTY
+
+ /* No termio, termios or sgtty. I suppose we can try stty,
+ but it would be nice if you could get a better OS */
+
+ if(mode==5)
+ system("/bin/stty raw -cbreak -isig -echo -ixon -onlcr -icrnl -brkint");
+ else if(mode==4)
+ system("/bin/stty -raw cbreak -isig -echo -ixon onlcr icrnl -brkint");
+ else if(mode==3)
+ system("/bin/stty -raw cbreak isig -echo ixon onlcr icrnl brkint");
+ else if(mode==2)
+ system("/bin/stty -raw -cbreak isig echo ixon onlcr icrnl brkint");
+ else if(mode==1)
+ system("/bin/stty -raw -cbreak isig -echo ixon onlcr icrnl brkint");
+ else if(mode==0)
+ system("/bin/stty -raw -cbreak isig echo ixon onlcr icrnl brkint");
+
+ /* Those probably won't work, but they couldn't hurt
+ at this point */
+
+#endif
+
+ /*warn("Mode set to %d.\n",mode);*/
+
+ if( firsttime ) {
+ hv_delete(filehash,(char*)&handle,sizeof(int),0);
+ hv_delete(modehash,(char*)&handle,sizeof(int),0);
+ } else {
+ if(!hv_store(modehash,(char*)&handle,sizeof(int),
+ newSViv(mode),0))
+ croak("Unable to stash terminal settings.\n");
+ }
+
+}
+
+#ifdef USE_PERLIO
+
+/* Make use of a recent addition to Perl, if possible */
+# define FCOUNT(f) PerlIO_get_cnt(f)
+#else
+
+ /* Make use of a recent addition to Configure, if possible */
+# ifdef USE_STDIO_PTR
+# define FCOUNT(f) PerlIO_get_cnt(f)
+# else
+ /* This bit borrowed from pp_sys.c. Complain to Larry if it's broken. */
+ /* If any of this works PerlIO_get_cnt() will too ... NI-S */
+# if defined(USE_STD_STDIO) || defined(atarist) /* this will work with atariST */
+# define FBASE(f) ((f)->_base)
+# define FSIZE(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
+# define FPTR(f) ((f)->_ptr)
+# define FCOUNT(f) ((f)->_cnt)
+# else
+# if defined(USE_LINUX_STDIO)
+# define FBASE(f) ((f)->_IO_read_base)
+# define FSIZE(f) ((f)->_IO_read_end - FBASE(f))
+# define FPTR(f) ((f)->_IO_read_ptr)
+# define FCOUNT(f) ((f)->_IO_read_end - FPTR(f))
+# endif
+# endif
+# endif
+#endif
+
+/* This is for the best, I'm afraid. */
+#if !defined(FCOUNT)
+# ifdef Have_select
+# undef Have_select
+# endif
+# ifdef Have_poll
+# undef Have_poll
+# endif
+#endif
+
+/* Note! If your machine has a bolixed up select() call that doesn't
+understand this syntax, either fix the checkwaiting call below, or define
+DONT_USE_SELECT. */
+
+#ifdef Have_select
+int selectfile(PerlIO *file,double delay)
+{
+ struct timeval t;
+ int handle=PerlIO_fileno(file);
+
+ /*char buf[32];
+ Select_fd_set_t fd=(Select_fd_set_t)&buf[0];*/
+
+ fd_set fd;
+ if (PerlIO_fast_gets(file) && PerlIO_get_cnt(file) > 0)
+ return 1;
+
+ /*t.tv_sec=t.tv_usec=0;*/
+
+ if (delay < 0.0)
+ delay = 0.0;
+ t.tv_sec = (long)delay;
+ delay -= (double)t.tv_sec;
+ t.tv_usec = (long)(delay * 1000000.0);
+
+ FD_ZERO(&fd);
+ FD_SET(handle,&fd);
+ if(select(handle+1,(Select_fd_set_t)&fd,
+ (Select_fd_set_t)0,
+ (Select_fd_set_t)&fd, &t)) return -1;
+ else return 0;
+}
+
+#else
+int selectfile(PerlIO *file, double delay)
+{
+ croak("select is not supported on this architecture");
+ return 0;
+}
+#endif
+
+#ifdef Have_nodelay
+int setnodelay(PerlIO *file, int mode)
+{
+ int handle=PerlIO_fileno(file);
+ int flags;
+ flags=fcntl(handle,F_GETFL,0);
+ if(mode)
+ flags|=O_NODELAY;
+ else
+ flags&=~O_NODELAY;
+ fcntl(handle,F_SETFL,flags);
+ return 0;
+}
+
+#else
+int setnodelay(PerlIO *file, int mode)
+{
+ croak("setnodelay is not supported on this architecture");
+ return 0;
+}
+#endif
+
+#ifdef Have_poll
+int pollfile(PerlIO *file,double delay)
+{
+ int handle=PerlIO_fileno(file);
+ struct pollfd fds;
+ if (PerlIO_fast_gets(f) && PerlIO_get_cnt(f) > 0)
+ return 1;
+ if(delay<0.0) delay = 0.0;
+ fds.fd=handle;
+ fds.events=POLLIN;
+ fds.revents=0;
+ return (poll(&fds,1,(long)(delay * 1000.0))>0);
+}
+#else
+int pollfile(PerlIO *file,double delay)
+{
+ croak("pollfile is not supported on this architecture");
+ return 0;
+}
+#endif
+
+#ifdef WIN32
+
+/*
+
+ This portion of the Win32 code is partially borrowed from a version of PDCurses.
+
+*/
+
+int Win32PeekChar(PerlIO *file,double delay,char *key)
+{
+ int handle;
+ HANDLE whnd;
+ INPUT_RECORD record;
+ DWORD readRecords;
+
+ static int keyCount = 0;
+ static char lastKey = 0;
+
+ file = STDIN;
+
+ handle = PerlIO_fileno(file);
+ whnd = /*GetStdHandle(STD_INPUT_HANDLE)*/(HANDLE)_get_osfhandle(handle);
+
+
+again:
+ if (keyCount > 0) {
+ keyCount--;
+ *key = lastKey;
+ return TRUE;
+ }
+
+ if (delay > 0) {
+ if (WaitForSingleObject(whnd, delay * 1000.0) != WAIT_OBJECT_0)
+ {
+ return FALSE;
+ }
+ }
+
+ if (delay != 0) {
+ PeekConsoleInput(whnd, &record, 1, &readRecords);
+ if (readRecords == 0)
+ return(FALSE);
+ }
+
+ ReadConsoleInput(whnd, &record, 1, &readRecords);
+ switch(record.EventType)
+ {
+ case KEY_EVENT:
+ /*printf("\nkeyDown = %d, repeat = %d, vKey = %d, vScan = %d, ASCII = %d, Control = %d\n",
+ record.Event.KeyEvent.bKeyDown,
+ record.Event.KeyEvent.wRepeatCount,
+ record.Event.KeyEvent.wVirtualKeyCode,
+ record.Event.KeyEvent.wVirtualScanCode,
+ record.Event.KeyEvent.uChar.AsciiChar,
+ record.Event.KeyEvent.dwControlKeyState);*/
+
+ if (record.Event.KeyEvent.bKeyDown == FALSE)
+ goto again; /* throw away KeyUp events */
+ if (record.Event.KeyEvent.wVirtualKeyCode == 16
+ || record.Event.KeyEvent.wVirtualKeyCode == 17
+ || record.Event.KeyEvent.wVirtualKeyCode == 18
+ || record.Event.KeyEvent.wVirtualKeyCode == 20
+ || record.Event.KeyEvent.wVirtualKeyCode == 144
+ || record.Event.KeyEvent.wVirtualKeyCode == 145)
+ goto again; /* throw away shift/alt/ctrl key only key events */
+ keyCount = record.Event.KeyEvent.wRepeatCount;
+ break;
+ default:
+ keyCount = 0;
+ goto again;
+ break;
+ }
+
+ *key = lastKey = record.Event.KeyEvent.uChar.AsciiChar;
+ keyCount--;
+
+ return(TRUE);
+
+ /* again:
+ return (FALSE);
+ */
+
+
+}
+#else
+int Win32PeekChar(PerlIO *file, double delay,char *key)
+{
+ croak("Win32PeekChar is not supported on this architecture");
+ return 0;
+}
+#endif
+
+
+int blockoptions() {
+ return 0
+#ifdef Have_nodelay
+ | 1
+#endif
+#ifdef Have_poll
+ | 2
+#endif
+#ifdef Have_select
+ | 4
+#endif
+#ifdef USE_WIN32
+ | 8
+#endif
+ ;
+}
+
+int termoptions() {
+ int i=0;
+#ifdef USE_TERMIOS
+ i=1;
+#endif
+#ifdef USE_TERMIO
+ i=2;
+#endif
+#ifdef USE_SGTTY
+ i=3;
+#endif
+#ifdef USE_STTY
+ i=4;
+#endif
+#ifdef USE_WIN32
+ i=5;
+#endif
+ return i;
+}
+
+
+
+MODULE = Term::ReadKey PACKAGE = Term::ReadKey
+
+int
+selectfile(file,delay)
+ InputStream file
+ double delay
+
+# Clever, eh?
+void
+SetReadMode(mode,file=STDIN)
+ int mode
+ InputStream file
+ CODE:
+ {
+ ReadMode(file,mode);
+ }
+
+int
+setnodelay(file,mode)
+ InputStream file
+ int mode
+
+int
+pollfile(file,delay)
+ InputStream file
+ double delay
+
+SV *
+Win32PeekChar(file, delay)
+ InputStream file
+ double delay
+ CODE:
+ {
+ char key;
+ if (Win32PeekChar(file, delay, &key))
+ RETVAL = newSVpv(&key, 1);
+ else
+ RETVAL = newSVsv(&PL_sv_undef);
+ }
+ OUTPUT:
+ RETVAL
+
+int
+blockoptions()
+
+int
+termoptions()
+
+int
+termsizeoptions()
+
+void
+GetTermSizeWin32(file=STDIN)
+ InputStream file
+ PPCODE:
+ {
+ int x,y,xpix,ypix;
+ if( GetTermSizeWin32(file,&x,&y,&xpix,&ypix)==0)
+ {
+ EXTEND(sp, 4);
+ PUSHs(sv_2mortal(newSViv((IV)x)));
+ PUSHs(sv_2mortal(newSViv((IV)y)));
+ PUSHs(sv_2mortal(newSViv((IV)xpix)));
+ PUSHs(sv_2mortal(newSViv((IV)ypix)));
+ }
+ else
+ {
+ ST(0) = sv_newmortal();
+ }
+ }
+
+void
+GetTermSizeVIO(file=STDIN)
+ InputStream file
+ PPCODE:
+ {
+ int x,y,xpix,ypix;
+ if( GetTermSizeVIO(file,&x,&y,&xpix,&ypix)==0)
+ {
+ EXTEND(sp, 4);
+ PUSHs(sv_2mortal(newSViv((IV)x)));
+ PUSHs(sv_2mortal(newSViv((IV)y)));
+ PUSHs(sv_2mortal(newSViv((IV)xpix)));
+ PUSHs(sv_2mortal(newSViv((IV)ypix)));
+ }
+ else
+ {
+ ST(0) = sv_newmortal();
+ }
+ }
+
+void
+GetTermSizeGWINSZ(file=STDIN)
+ InputStream file
+ PPCODE:
+ {
+ int x,y,xpix,ypix;
+ if( GetTermSizeGWINSZ(file,&x,&y,&xpix,&ypix)==0)
+ {
+ EXTEND(sp, 4);
+ PUSHs(sv_2mortal(newSViv((IV)x)));
+ PUSHs(sv_2mortal(newSViv((IV)y)));
+ PUSHs(sv_2mortal(newSViv((IV)xpix)));
+ PUSHs(sv_2mortal(newSViv((IV)ypix)));
+ }
+ else
+ {
+ ST(0) = sv_newmortal();
+ }
+ }
+
+void
+GetTermSizeGSIZE(file=STDIN)
+ InputStream file
+ PPCODE:
+ {
+ int x,y,xpix,ypix;
+ if( GetTermSizeGSIZE(file,&x,&y,&xpix,&ypix)==0)
+ {
+ EXTEND(sp, 4);
+ PUSHs(sv_2mortal(newSViv((IV)x)));
+ PUSHs(sv_2mortal(newSViv((IV)y)));
+ PUSHs(sv_2mortal(newSViv((IV)xpix)));
+ PUSHs(sv_2mortal(newSViv((IV)ypix)));
+ }
+ else
+ {
+ ST(0) = sv_newmortal();
+ }
+ }
+
+int
+SetTerminalSize(width,height,xpix,ypix,file=STDIN)
+ int width
+ int height
+ int xpix
+ int ypix
+ InputStream file
+ CODE:
+ {
+ RETVAL=SetTerminalSize(file,width,height,xpix,ypix);
+ }
+
+void
+GetSpeed(file=STDIN)
+ InputStream file
+ PPCODE:
+ {
+ I32 in,out;
+ if(items!=0) {
+ croak("Usage: Term::ReadKey::GetSpeed()");
+ }
+ if(getspeed(file,&in,&out)) {
+ /* Failure */
+ ST( 0) = sv_newmortal();
+ } else {
+ EXTEND(sp, 2);
+ PUSHs(sv_2mortal(newSViv((IV)in)));
+ PUSHs(sv_2mortal(newSViv((IV)out)));
+ }
+ }
+
+
+
+BOOT:
+newXS("Term::ReadKey::GetControlChars", XS_Term__ReadKey_GetControlChars, file);
+newXS("Term::ReadKey::SetControlChars", XS_Term__ReadKey_SetControlChars, file);
+filehash=newHV();
+modehash=newHV();
Added: packages/libterm-readkey-perl/branches/upstream/current/genchars.pl
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/genchars.pl 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/genchars.pl 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,489 @@
+#!/usr/bin/perl
+
+#
+# $Id: genchars.pl,v 1.3 2002/01/28 18:40:18 gellyfish Exp $
+#
+##############################
+$version="1.97";
+##############################
+use Config;
+
+use Configure;
+
+#sub report {
+# my($prog)=join(" ", at _);
+#
+# my($ccflags, $ldflags, $cc, $rm) = @Config{'ccflags', 'ldflags', 'cc', 'rm'};
+# my($command, $ret);
+#
+# $command = $prog;
+# open(F, ">temp$$.c") || die "Can't make temp file temp$$.c! $!\n";
+# print F $command;
+# close F;
+#
+# $command = "$cc $ccflags -o temp$$ temp$$.c $ldfcrs $libcrs $ldflags -lbsd";
+# $command .= " >/dev/null 2>&1";
+# $ret = system $command;
+# #if(!$ret) { system "temp$$" }
+# unlink "temp$$", "temp$$.o", "temp$$.c";
+#
+# return $ret;
+#}
+
+open(CCHARS,">cchars.h") || die "Fatal error, Unable to write to cchars.h!";
+
+#print "Checking for termio...\n";
+#$TERMIO = !report( "#include <termio.h>\n struct termios s; main(){}");
+#print " Termio ",($TERMIO?"":"NOT "),"found.\n";
+
+#print "Checking for termios...\n";
+#$TERMIOS = !report( "#include <termios.h>\n struct termio s; main(){}");
+#print " Termios ",($TERMIOS?"":"NOT "),"found.\n";
+
+#print "Checking for sgtty...\n";
+#$SGTTY = !report( "#include <sgtty.h>\n struct sgttyb s; main(){}");
+#print " Sgtty ",($SGTTY?"":"NOT "),"found.\n";
+
+#print "Termio=$TERMIO, Termios=$TERMIOS, Sgtty=$SGTTY\n";
+
+# Control characters used for termio and termios
+%possible = ( VINTR => "INTERRUPT",
+ VQUIT => "QUIT",
+ VERASE => "ERASE",
+ VKILL => "KILL",
+ VEOF => "EOF",
+ VTIME => "TIME",
+ VMIN => "MIN",
+ VSWTC => "SWITCH",
+ VSWTCH => "SWITCH",
+ VSTART => "START",
+ VSTOP => "STOP",
+ VSUSP => "SUSPEND",
+ VDSUSP => "DSUSPEND",
+ VEOL => "EOL",
+ VREPRINT => "REPRINT",
+ VDISCARD => "DISCARD",
+ VFLUSH => "DISCARD",
+ VWERASE => "ERASEWORD",
+ VLNEXT => "QUOTENEXT",
+ VQUOTE => "QUOTENEXT",
+ VEOL2 => "EOL2",
+ VSTATUS => "STATUS",
+);
+
+# Control characters for sgtty
+%possible2 = ( "intrc" => "INTERRUPT",
+ "quitc" => "QUIT",
+ "eofc" => "EOF",
+ "startc"=> "START",
+ "stopc" => "STOP",
+ "brkc" => "EOL",
+ "eolc" => "EOL",
+ "suspc" => "SUSPEND",
+ "dsuspc"=> "DSUSPEND",
+ "rprntc"=> "REPRINT",
+ "flushc"=> "DISCARD",
+ "lnextc"=> "QUOTENEXT",
+ "werasc"=> "ERASEWORD",
+);
+
+print CCHARS "
+
+/* Written by genchars.pl version $version */
+
+";
+
+print CCHARS "#define HAVE_POLL_H\n" if CheckHeader("poll.h");
+print CCHARS "#define HAVE_SYS_POLL_H\n" if CheckHeader("sys/poll.h");
+
+print "\n";
+if(1) {
+ @values = sort { $possible{$a} cmp $possible{$b} } keys %possible;
+
+ print "Writing termio/termios section of cchars.h... ";
+ print CCHARS "
+
+#ifdef CC_TERMIOS
+# define TermStructure struct termios
+# ifdef NCCS
+# define LEGALMAXCC NCCS
+# else
+# ifdef NCC
+# define LEGALMAXCC NCC
+# endif
+# endif
+#else
+# ifdef CC_TERMIO
+# define TermStructure struct termio
+# ifdef NCC
+# define LEGALMAXCC NCC
+# else
+# ifdef NCCS
+# define LEGALMAXCC NCCS
+# endif
+# endif
+# endif
+#endif
+
+#if !defined(LEGALMAXCC)
+# define LEGALMAXCC 126
+#endif
+
+#if defined(CC_TERMIO) || defined(CC_TERMIOS)
+
+char * cc_names[] = { ".join('',map("
+#if defined($_) && ($_ < LEGALMAXCC)
+ \"$possible{$_}\", "."
+#else "."
+ \"\", "."
+#endif ", @values ))."
+};
+
+const int MAXCC = 0 ",join('',map("
+#if defined($_) && ($_ < LEGALMAXCC)
+ +1 /* $possible{$_} */
+#endif ", @values ))."
+ ;
+
+XS(XS_Term__ReadKey_GetControlChars)
+{
+ dXSARGS;
+ if (items < 0 || items > 1) {
+ croak(\"Usage: Term::ReadKey::GetControlChars()\");
+ }
+ SP -= items;
+ {
+ PerlIO * file;
+ TermStructure s;
+ if (items < 1)
+ file = STDIN;
+ else {
+ file = IoIFP(sv_2io(ST(0)));
+ }
+
+#ifdef CC_TERMIOS
+ if(tcgetattr(PerlIO_fileno(file),&s))
+#else
+# ifdef CC_TERMIO
+ if(ioctl(fileno(PerlIO_file),TCGETA,&s))
+# endif
+#endif
+ croak(\"Unable to read terminal settings in GetControlChars\");
+ else {
+ int i;
+ EXTEND(sp,MAXCC*2); ".join('',map("
+#if defined($values[$_]) && ($values[$_] < LEGALMAXCC) "."
+PUSHs(sv_2mortal(newSVpv(cc_names[$_],strlen(cc_names[$_])))); /* $possible{$values[$_]} */
+PUSHs(sv_2mortal(newSVpv((char*)&s.c_cc[$values[$_]],1))); "."
+#endif " ,0..$#values))."
+
+ }
+ PUTBACK;
+ return;
+ }
+}
+
+XS(XS_Term__ReadKey_SetControlChars)
+{
+ dXSARGS;
+ /*if ((items % 2) != 0) {
+ croak(\"Usage: Term::ReadKey::SetControlChars(%charpairs,file=STDIN)\");
+ }*/
+ SP -= items;
+ {
+ TermStructure s;
+ PerlIO * file;
+ if ((items % 2) == 1)
+ file = IoIFP(sv_2io(ST(items-1)));
+ else {
+ file = STDIN;
+ }
+
+#ifdef CC_TERMIOS
+ if(tcgetattr(PerlIO_fileno(file),&s))
+#else
+# ifdef CC_TERMIO
+ if(ioctl(fileno(PerlIO_file),TCGETA,&s))
+# endif
+#endif
+ croak(\"Unable to read terminal settings in SetControlChars\");
+ else {
+ int i;
+ char * name, value;
+ for(i=0;i+1<items;i+=2) {
+ name = SvPV(ST(i),PL_na);
+ if( SvIOKp(ST(i+1)) || SvNOKp(ST(i+1)) )/* If Int or Float */
+ value = (char)SvIV(ST(i+1)); /* Store int value */
+ else /* Otherwise */
+ value = SvPV(ST(i+1),PL_na)[0]; /* Use first char of PV */
+
+ if (0) ; ".join('',map("
+#if defined($values[$_]) && ($values[$_] < LEGALMAXCC) "."
+ else if(strcmp(name,cc_names[$_])==0) /* $possible{$values[$_]} */
+ s.c_cc[$values[$_]] = value; "."
+#endif ",0..$#values))."
+ else
+ croak(\"Invalid control character passed to SetControlChars\");
+
+ }
+#ifdef CC_TERMIOS
+ if(tcsetattr(PerlIO_fileno(file),TCSANOW,&s))
+#else
+# ifdef CC_TERMIO
+ if(ioctl(fileno(PerlIO_file),TCSETA,&s))
+# endif
+#endif
+ croak(\"Unable to write terminal settings in SetControlChars\");
+ }
+ }
+ XSRETURN(1);
+}
+
+
+#endif
+
+";
+
+ print "Done.\n";
+
+}
+
+undef %billy;
+
+if(@ARGV) { # If any argument is supplied on the command-line don't check sgtty
+ $SGTTY=0; #skip tests
+} else {
+ print "Checking for sgtty...\n";
+
+ $SGTTY = CheckStructure "sgttyb","sgtty.h";
+# $SGTTY = !Compile("
+##include <sgtty.h>
+#struct sgttyb s;
+#main(){
+#ioctl(0,TIOCGETP,&s);
+#}");
+
+#}
+
+# $SGTTY = !report("
+##include <sgtty.h>
+#struct sgttyb s;
+#main(){
+#ioctl(0,TIOCGETP,&s);
+#}");
+
+ print " Sgtty ",($SGTTY?"":"NOT "),"found.\n";
+}
+
+$billy{"ERASE"} = "s1.sg_erase";
+$billy{"KILL"} = "s1.sg_kill";
+$tchars=$ltchars=0;
+
+if($SGTTY) {
+
+ print "Checking sgtty...\n";
+
+ $tchars = CheckStructure "tchars","sgtty.h";
+# $tchars = !report( '
+##include <sgtty.h>
+#struct tchars t;
+#main() { ioctl(0,TIOCGETC,&t); }
+#');
+ print " tchars structure found.\n" if $tchars;
+
+ $ltchars = CheckStructure "ltchars","sgtty.h";
+# $ltchars = !report( '
+##include <sgtty.h>
+#struct ltchars t;
+#main() { ioctl(0,TIOCGLTC,&t); }
+#');
+
+ print " ltchars structure found.\n" if $ltchars;
+
+
+ print "Checking symbols\n";
+
+
+ for $c (keys %possible2) {
+
+# if($tchars and !report("
+##include <sgtty.h>
+#struct tchars s2;
+#main () { char c = s2.t_$c; }
+#")) {
+ if($tchars and CheckField("tchars","t_$c","sgtty.h")) {
+
+ print " t_$c ($possible2{$c}) found in tchars\n";
+ $billy{$possible2{$c}} = "s2.t_$c";
+ }
+
+# elsif($ltchars and !report("
+##include <sgtty.h>
+#struct ltchars s3;
+#main () { char c = s3.t_$c; }
+#")) {
+ elsif($ltchars and CheckField("ltchars","t_$c","sgtty.h")) {
+ print " t_$c ($possible2{$c}) found in ltchars\n";
+ $billy{$possible2{$c}} = "s3.t_$c";
+ }
+
+ }
+
+
+ #undef @names;
+ #undef @values;
+ #for $v (sort keys %billy) {
+ # push(@names,$billy{$v});
+ # push(@values,$v);
+ #}
+
+ #$numchars = keys %billy;
+
+}
+
+ at values = sort keys %billy;
+
+ $struct = "
+struct termstruct {
+ struct sgttyb s1;
+";
+ $struct .= "
+ struct tchars s2;
+" if $tchars;
+ $struct .= "
+ struct ltchars s3;
+" if $ltchars;
+ $struct .= "
+};";
+
+print "Writing sgtty section of cchars.h... ";
+
+ print CCHARS "
+
+#ifdef CC_SGTTY
+$struct
+#define TermStructure struct termstruct
+
+char * cc_names[] = { ".join('',map("
+ \"$_\", ", @values ))."
+};
+
+#define MAXCC ". ($#values+1)."
+
+XS(XS_Term__ReadKey_GetControlChars)
+{
+ dXSARGS;
+ if (items < 0 || items > 1) {
+ croak(\"Usage: Term::ReadKey::GetControlChars()\");
+ }
+ SP -= items;
+ {
+ PerlIO * file;
+ TermStructure s;
+ if (items < 1)
+ file = STDIN;
+ else {
+ file = IoIFP(sv_2io(ST(0)));
+ }
+ if(ioctl(fileno(PerlIO_file),TIOCGETP,&s.s1) ".($tchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCGETC,&s.s2) ":'').($ltchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCGLTC,&s.s3) ":'')."
+ )
+ croak(\"Unable to read terminal settings in GetControlChars\");
+ else {
+ int i;
+ EXTEND(sp,MAXCC*2); ".join('',map("
+PUSHs(sv_2mortal(newSVpv(cc_names[$_],strlen(cc_names[$_])))); /* $values[$_] */
+PUSHs(sv_2mortal(newSVpv(&s.$billy{$values[$_]},1))); ",0..$#values))."
+
+ }
+ PUTBACK;
+ return;
+ }
+}
+
+XS(XS_Term__ReadKey_SetControlChars)
+{
+ dXSARGS;
+ /*if ((items % 2) != 0) {
+ croak(\"Usage: Term::ReadKey::SetControlChars(%charpairs,file=STDIN)\");
+ }*/
+ SP -= items;
+ {
+ PerlIO * file;
+ TermStructure s;
+ if ((items%2)==0)
+ file = STDIN;
+ else {
+ file = IoIFP(sv_2io(ST(items-1)));
+ }
+
+ if(ioctl(PerlIO_fileno(file),TIOCGETP,&s.s1) ".($tchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCGETC,&s.s2) ":'').($ltchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCGLTC,&s.s3) ":'')."
+ )
+ croak(\"Unable to read terminal settings in SetControlChars\");
+ else {
+ int i;
+ char * name, value;
+ for(i=0;i+1<items;i+=2) {
+ name = SvPV(ST(i),PL_na);
+ if( SvIOKp(ST(i+1)) || SvNOKp(ST(i+1)) )/* If Int or Float */
+ value = (char)SvIV(ST(i+1)); /* Store int value */
+ else /* Otherwise */
+ value = SvPV(ST(i+1),PL_na)[0]; /* Use first char of PV */
+
+ if (0) ; ".join('',map("
+ else if(strcmp(name,cc_names[$_])==0) /* $values[$_] */
+ s.$billy{$values[$_]} = value; ",0..$#values))."
+ else
+ croak(\"Invalid control character passed to SetControlChars\");
+
+ }
+ if(ioctl(fileno(PerlIO_file),TIOCSETN,&s.s1) ".($tchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCSETC,&s.s2) ":'').($ltchars?"
+ ||ioctl(fileno(PerlIO_file),TIOCSLTC,&s.s3) ":'')."
+ ) croak(\"Unable to write terminal settings in SetControlChars\");
+ }
+ }
+ XSRETURN(1);
+}
+
+#endif
+
+#if !defined(CC_TERMIO) && !defined(CC_TERMIOS) && !defined(CC_SGTTY)
+#define TermStructure int
+XS(XS_Term__ReadKey_GetControlChars)
+{
+ dXSARGS;
+ if (items <0 || items>1) {
+ croak(\"Usage: Term::ReadKey::GetControlChars([FileHandle])\");
+ }
+ SP -= items;
+ {
+ ST(0) = sv_newmortal();
+ PUTBACK;
+ return;
+ }
+}
+
+XS(XS_Term__ReadKey_SetControlChars)
+{
+ dXSARGS;
+ if (items < 0 || items > 1) {
+ croak(\"Invalid control character passed to SetControlChars\");
+ }
+ SP -= items;
+ XSRETURN(1);
+}
+
+#endif
+
+";
+
+print "Done.\n";
+
+
+
+
+
Added: packages/libterm-readkey-perl/branches/upstream/current/ppport.h
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/ppport.h 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/ppport.h 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,424 @@
+/* Perl/Pollution/Portability Version 2.0000 */
+
+/* Automatically Created by Devel::PPPort on Fri Nov 23 07:08:17 2001 */
+
+/* Do NOT edit this file directly! -- edit PPPort.pm instead. */
+
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
+ distributed under the same license as any version of Perl. */
+
+/* For the latest version of this code, please retreive the Devel::PPPort
+ module from CPAN, contact the author at <kjahds at kjahds.com>, or check
+ with the Perl maintainers. */
+
+/* If you needed to customize this file for your project, please mention
+ your changes, and visible alter the version number. */
+
+
+/*
+ In order for a Perl extension module to be as portable as possible
+ across differing versions of Perl itself, certain steps need to be taken.
+ Including this header is the first major one, then using dTHR is all the
+ appropriate places and using a PL_ prefix to refer to global Perl
+ variables is the second.
+*/
+
+
+/* If you use one of a few functions that were not present in earlier
+ versions of Perl, please add a define before the inclusion of ppport.h
+ for a static include, or use the GLOBAL request in a single module to
+ produce a global definition that can be referenced from the other
+ modules.
+
+ Function: Static define: Extern define:
+ newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+
+*/
+
+
+/* To verify whether ppport.h is needed for your module, and whether any
+ special defines should be used, ppport.h can be run through Perl to check
+ your source code. Simply say:
+
+ perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
+
+ The result will be a list of patches suggesting changes that should at
+ least be acceptable, if not necessarily the most efficient solution, or a
+ fix for all possible problems. It won't catch where dTHR is needed, and
+ doesn't attempt to account for global macro or function definitions,
+ nested includes, typemaps, etc.
+
+ In order to test for the need of dTHR, please try your module under a
+ recent version of Perl that has threading compiled-in.
+
+*/
+
+
+/*
+
+#!/usr/bin/perl
+ at ARGV = ("*.xs") if !@ARGV;
+%badmacros = %funcs = %macros = (); $replace = 0;
+foreach (<DATA>) {
+ $funcs{$1} = 1 if /Provide:\s+(\S+)/;
+ $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
+ $replace = $1 if /Replace:\s+(\d+)/;
+ $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
+ $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
+}
+foreach $filename (map(glob($_), at ARGV)) {
+ unless (open(IN, "<$filename")) {
+ warn "Unable to read from $file: $!\n";
+ next;
+ }
+ print "Scanning $filename...\n";
+ $c = ""; while (<IN>) { $c .= $_; } close(IN);
+ $need_include = 0; %add_func = (); $changes = 0;
+ $has_include = ($c =~ /#.*include.*ppport/m);
+
+ foreach $func (keys %funcs) {
+ if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
+ if ($c !~ /\b$func\b/m) {
+ print "If $func isn't needed, you don't need to request it.\n" if
+ $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
+ } else {
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ } else {
+ if ($c =~ /\b$func\b/m) {
+ $add_func{$func} =1 ;
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ if (not $need_include) {
+ foreach $macro (keys %macros) {
+ if ($c =~ /\b$macro\b/m) {
+ print "Uses $macro\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ foreach $badmacro (keys %badmacros) {
+ if ($c =~ /\b$badmacro\b/m) {
+ $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
+ print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
+ $need_include = 1;
+ }
+ }
+
+ if (scalar(keys %add_func) or $need_include != $has_include) {
+ if (!$has_include) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
+ "#include \"ppport.h\"\n";
+ $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
+ } elsif (keys %add_func) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
+ $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
+ }
+ if (!$need_include) {
+ print "Doesn't seem to need ppport.h.\n";
+ $c =~ s/^.*#.*include.*ppport.*\n//m;
+ }
+ $changes++;
+ }
+
+ if ($changes) {
+ open(OUT,">/tmp/ppport.h.$$");
+ print OUT $c;
+ close(OUT);
+ open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
+ while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
+ close(DIFF);
+ unlink("/tmp/ppport.h.$$");
+ } else {
+ print "Looks OK\n";
+ }
+}
+__DATA__
+*/
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfpv rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(d) (IV)(d)
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(d)
+#endif
+
+#ifndef dTHR
+# ifdef WIN32
+# define dTHR extern int Perl___notused
+# else
+# define dTHR extern int errno
+# endif
+#endif
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if PERL_REVISION == 5 && \
+ (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+# define PERL_UNUSED_DECL __attribute__((unused))
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+
+#endif /* _P_P_PORTABILITY_H_ */
Added: packages/libterm-readkey-perl/branches/upstream/current/test.pl
===================================================================
--- packages/libterm-readkey-perl/branches/upstream/current/test.pl 2005-07-12 10:42:46 UTC (rev 1224)
+++ packages/libterm-readkey-perl/branches/upstream/current/test.pl 2005-07-12 11:56:20 UTC (rev 1225)
@@ -0,0 +1,319 @@
+#!/usr/bin/perl -w
+
+#use strict vars;
+
+#use Term::ReadKey qw( ReadMode ReadKey );
+#my $x;
+#ReadMode 3;
+#print "Read 1\n";
+#$x = ReadKey(0);
+#print "X=$x\n";
+#print "Read 2\n";
+#$x = ReadKey(0);
+#print "X=$x\n";
+#ReadMode 0;
+#__END__;
+
+
+my $interactive = (@ARGV && $ARGV[0] =~ /interactive/ );
+
+BEGIN { print "1 .. 8\n"; }
+END { print "not ok 1\n" unless $loaded }
+use Term::ReadKey;
+
+$loaded = 1;
+print "ok 1\n";
+
+use Fcntl;
+
+if ( not exists $ENV{COLUMNS} )
+{
+ $ENV{COLUMNS} = 80;
+ $ENV{LINES} = 24;
+}
+
+if ($^O =~ /Win32/i) {
+ sysopen(IN,'CONIN$',O_RDWR) or die "Unable to open console input:$!";
+ sysopen(OUT,'CONOUT$',O_RDWR) or die "Unable to open console output:$!";
+} else {
+
+ if ( open(IN,"</dev/tty") ) {
+ *OUT = *IN;
+ die "Foo" unless -t OUT;
+ }
+ else {
+ die "Can't open /dev/tty - $!\n";
+ }
+}
+
+*IN=*IN; # Make single-use warning go away
+$|=1;
+
+
+
+my $size1 = join(",",GetTerminalSize(\IN));
+my $size2 = join(",",GetTerminalSize("IN"));
+my $size3 = join(",",GetTerminalSize(*IN));
+my $size4 = join(",",GetTerminalSize(\*IN));
+
+if (($size1 eq $size2) && ($size2 eq $size3) && ($size3 eq $size4 ))
+{
+ print "ok 2\n";
+}
+else
+{
+ print "not ok 2\n";
+}
+
+sub makenicelist {
+ my(@list) = @_;
+ my($i,$result);
+ $result="";
+ for($i=0;$i<@list;$i++) {
+ $result .= ", " if $i>0;
+ $result .= "and " if $i==@list-1 and @list>1;
+ $result .= $list[$i];
+ }
+ $result;
+}
+
+sub makenice {
+ my($char) = $_[0];
+ if(ord($char)<32) { $char = "^" . pack("c",ord($char)+64) }
+ elsif(ord($char)>126) { $char = ord($char) }
+ $char;
+}
+
+sub makeunnice {
+ my($char) = $_[0];
+ $char =~ s/^\^(.)$/pack("c",ord($1)-64)/eg;
+ $char =~ s/(\d{1,3})/pack("c",$1+0)/eg;
+ $char;
+}
+
+
+my $response;
+
+eval {
+
+if( &Term::ReadKey::termoptions() == 1) {
+ $response = "Term::ReadKey is using TERMIOS, as opposed to TERMIO or SGTTY.\n";
+} elsif( &Term::ReadKey::termoptions() == 2) {
+ $response = "Term::ReadKey is using TERMIO, as opposed to TERMIOS or SGTTY.\n";
+} elsif( &Term::ReadKey::termoptions() == 3) {
+ $response = "Term::ReadKey is using SGTTY, as opposed to TERMIOS or TERMIO.\n";
+} elsif( &Term::ReadKey::termoptions() == 4) {
+ $response = "Term::ReadKey is trying to make do with stty; facilites may be limited.\n";
+} elsif( &Term::ReadKey::termoptions() == 5) {
+ $response = "Term::ReadKey is using Win32 functions.\n";
+} else {
+ $response = "Term::ReadKey could not find any way to manipulate the terminal.\n";
+}
+
+ print "ok 3\n";
+};
+
+print "not ok 3\n" if $@;
+
+print $response if $interactive;
+
+eval
+{
+ push(@modes,"O_NODELAY") if &Term::ReadKey::blockoptions() & 1;
+ push(@modes,"poll()") if &Term::ReadKey::blockoptions() & 2;
+ push(@modes,"select()") if &Term::ReadKey::blockoptions() & 4;
+ push(@modes,"Win32") if &Term::ReadKey::blockoptions() & 8;
+
+ print "ok 4\n";
+};
+
+print "not ok 4\n" if $@;
+
+if ($interactive )
+{
+ if(&Term::ReadKey::blockoptions()==0)
+ {
+ print "No methods found to implement non-blocking reads.\n";
+ print " (If your computer supports poll(), you might like to read through ReadKey.xs)\n";
+ }
+ else
+ {
+ print "Non-blocking reads possible via ",makenicelist(@modes),".\n";
+ print $modes[0]." will be used. " if @modes>0;
+ print $modes[1]." will be used for timed reads." if @modes>1 and $modes[0] eq "O_NODELAY";
+ print "\n";
+ }
+}
+
+
+eval
+{
+ @size = GetTerminalSize(OUT);
+ print "ok 5\n";
+};
+
+print "not ok 5\n" if $@;
+
+if ( $interactive )
+{
+ if(!@size) {
+ print "GetTerminalSize was incapable of finding the size of your terminal.";
+ } else {
+ print "Using GetTerminalSize, it appears that your terminal is\n";
+ print "$size[0] characters wide by $size[1] high.\n\n";
+ }
+
+}
+
+eval
+{
+ @speeds = GetSpeed();
+ print "ok 6\n";
+};
+
+print "not ok 6\n" if $@;
+
+if ( $interactive )
+{
+ if(@speeds) {
+ print "Apparently, you are connected at ",join("/", at speeds)," baud.\n";
+ } else {
+ print "GetSpeed couldn't tell your connection baud rate.\n\n";
+ }
+ print "\n";
+}
+
+eval
+{
+ %chars = GetControlChars(IN);
+ print "ok 7\n";
+};
+
+print "not ok 7\n" if $@;
+
+%origchars = %chars;
+
+if ( $interactive )
+{
+ for $c (keys %chars) { $chars{$c} = makenice($chars{$c}) }
+
+ print "Control chars = (",join(', ',map("$_ => $chars{$_}",keys %chars)),")\n";
+}
+
+eval
+{
+ SetControlChars(%origchars, IN);
+ print "ok 8\n";
+};
+
+print "not ok 8\n" if $@;
+
+#SetControlChars("FOOFOO"=>"Q");
+#SetControlChars("INTERRUPT"=>"\x5");
+
+END { ReadMode 0, IN; } # Just if something goes weird
+
+exit(0) unless $interactive;
+
+print "\nAnd now for the interactive tests.\n";
+
+print "\nThis is ReadMode 1. It's guarranteed to give you cooked input. All the\n";
+print "signals and editing characters may be used as usual.\n";
+
+ReadMode 1, IN;
+
+print "\nYou may enter some text here: ";
+
+$t = ReadLine 0, IN;
+
+chop $t;
+
+print "\nYou entered `$t'.\n";
+
+ReadMode 2, IN;
+
+print "\nThis is ReadMode 2. It's just like #1, but echo is turned off. Great\n";
+print "for passwords.\n";
+
+print "\nYou may enter some invisible text here: ";
+
+$t = ReadLine 0, IN;
+
+chop $t;
+
+print "\nYou entered `$t'.\n";
+
+
+ReadMode 3, IN;
+
+print "\nI won't demonstrate ReadMode 3 here. It's your standard cbreak mode,\n";
+print "with editing characters disabled, single character at a time input, but\n";
+print "with the control characters still enabled.\n";
+
+print "\n";
+
+print "I'm now putting the terminal into ReadMode 4 and using non-blocking reads.\n";
+print "All signals should be disabled, including xon-xoff. You should only be\n";
+print "able to exit this loop via 'q'.\n";
+
+ReadMode 4, IN;
+$k = "";
+#$in = *STDIN;
+$in = \*IN; # or *IN or "IN"
+while($k ne "q")
+{
+ print "Press a key, or \"q\" to stop: ";
+ $count=0;
+ #print "IN = $in\n";
+ $count++ while !defined($k=ReadKey(-1, $in));
+ #print "IN2 = $in\n";
+ print "\nYou pressed `",makenice($k),"' after the loop rolled over $count times\n";
+}
+ReadMode 0, IN;
+
+print "\nHere is a similar loop which times out after two seconds:\n";
+
+ReadMode 4, IN;
+$k = "";
+#$in = *STDIN;
+$in = \*IN; # or *IN or "IN"
+while($k ne "q")
+{
+ print "Press a key, or \"q\" to stop: ";
+ $count=0;
+ #print "IN = $in\n";
+ print "Timeout! " while !defined($k=ReadKey(2, $in));
+ #print "IN2 = $in\n";
+ print "\nYou pressed `",makenice($k),"'\n";
+}
+
+print "\nLastly, ReadMode 5, which also affects output (except under Win32).\n\n";
+
+ReadMode 5, IN;
+
+print "This should be a diagonal line (except under Win32): *\n*\n*\n\*\n*\n*\r\n\r\n";
+print "And this should be a moving spot:\r\n\r\n";
+
+$width = (GetTerminalSize(OUT))[0];
+$width/=2;
+$width--;
+if($width<10) { $width=10;}
+
+for ($i=0;$i<20;$i+=.15) {
+ print "\r";
+ print (" " x ((cos($i)+1)*$width));
+ print "*";
+ select(undef, undef, undef, 0.01);
+ print "\r";
+ print (" " x ((cos($i)+1)*$width));
+ print " ";
+}
+print "\r ";
+
+print "\n\r\n";
+
+
+ReadMode 0, IN;
+
+print "That's all, folks!\n";
+
More information about the Pkg-perl-cvs-commits
mailing list