[comp.lang.perl] New version of termcap.pl

al@ee.pitt.edu (Alan Martello) (02/24/90)

Here is a new version of the library "termcap.pl" which correctly (?)
works on SunOS 4.0.1 under X11R4.  If it fixes anyone else's problems,
great, if not, oh well.  If this has been superseded by something
newer in patches 7 or 8 or another posting, my apologies (after all
what do you want for free?).  I'm posting the entire thing since
the context diffs are only 300 bytes shorter.

*******************************************************************
       Alan R. Martello        Electrical Engineering Dept.
        al@ee.pitt.edu           University of Pittsburgh
*******************************************************************
-------------------   CUT HERE ------------------------
;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $
;#
;# Usage:
;#	do 'ioctl.pl';
;#	ioctl(TTY,$TIOCGETP,$foo);
;#	($ispeed,$ospeed) = unpack('cc',$foo);
;#	do 'termcap.pl';
;#	do Tgetent('vt100');	# sets $TC{'cm'}, etc.
;#	do Tgoto($TC{'cm'},$col,$row);
;#	do Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
;#
;#  modified to work "correctly" (?) under X11R4 , SunOS 4.0  2/22/90
sub Tgetent {
    local($TERM) = @_;
    local($TERMCAP,$_,$entry,$loop,$field);

    warn "Tgetent: no ospeed set" unless $ospeed;
    foreach $key (keys(TC)) {
	delete $TC{$key};
    }
    $TERM = $ENV{'TERM'} unless $TERM;
    $TERMCAP = $ENV{'TERMCAP'};
    $TERMCAP = '/etc/termcap' unless $TERMCAP;
    if ($TERMCAP !~ m:^/:) {
	if (index($TERMCAP,"|$TERM|") < $[) {
	    $TERMCAP = '/etc/termcap';
	}
    }
    if ($TERMCAP =~ m:^/:) {
	$entry = '';
	do {
	    $loop = "
	    open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
	    while (<TERMCAP>) {
		next if /^#/;
		next if /^\t/;
		if (/\\|$TERM[:\\|]/) {
		    chop;
		    while (chop eq '\\\\') {
			\$_ .= <TERMCAP>;
			chop;
		    }
		    \$_ .= ':';
		    last;
		}
	    }
	    close TERMCAP;
	    \$entry .= \$_;
	    ";
	    eval $loop;
	} while s/:tc=([^:]+):/:/, $TERM = $1;
	$TERMCAP = $entry;
    }

    foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
	if ($field =~ /^\w\w$/) {
	    $TC{$field} = 1;
	}
	elsif ($field =~ /^(\w\w)#(.*)/) {
	    $TC{$1} = $2 if $TC{$1} eq '';
	}
	elsif ($field =~ /^(\w\w)=(.*)/) {
	    $entry = $1;
	    $_ = $2;
	    s/\\E/\033/g;
	    s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
	    s/\\n/\n/g;
	    s/\\r/\r/g;
	    s/\\t/\t/g;
	    s/\\b/\b/g;
	    s/\\f/\f/g;
	    s/\\\^/\377/g;
	    s/\^\?/\177/g;
	    s/\^(.)/pack('c',$1 & 031)/eg;
	    s/\\(.)/$1/g;
	    s/\377/^/g;
	    $TC{$entry} = $_ if $TC{$entry} eq '';
	}
    }
    $TC{'pc'} = "\0" if $TC{'pc'} eq '';
    $TC{'bc'} = "\b" if $TC{'bc'} eq '';
}

@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);

sub Tputs {
    local($string,$affcnt,$FH) = @_;
    local($ms);
    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
	$ms = $1;
	$ms *= $affcnt if $2;
	$string = $3;
	$decr = $Tputs[$ospeed];
	if ($decr > .1) {
	    $ms += $decr / 2;
	    $string .= $TC{'pc'} x ($ms / $decr);
	}
    }
    print $FH $string if $FH;
    $string;
}

sub Tgoto {
    local($string) = shift(@_);
    local($result) = '';
    local($after) = '';
    local($code,$tmp) = @_;
    local($online) = 0;
    local($tmp_ary);

    @tmp_ary = ($tmp,$code);		# swap the order of the parameters

    # strip off any leading delay
    if ($string =~ /^\d+(.*)/) {
	$string = $1;
    }

    while ($string =~ /^([^%]*)%(.)(.*)/) {
	$result .= $1;
	$code = $2;
	$string = $3;

	if ($code eq 'd') {
            $tmp = shift(@tmp_ary);
	    $result .= sprintf("%d",$tmp);
	}
	elsif ($code eq '.') {
	    $tmp = shift(@tmp_ary);
	    if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
		if ($online) {
		    ++$tmp, $after .= $TC{'up'} if $TC{'up'};
		}
		else {
		    ++$tmp, $after .= $TC{'bc'};
		}
	    }
	    $result .= sprintf("%c",$tmp);
	    $online = !$online;
	}
	elsif ($code eq '+') {
	    $result .= sprintf("%c",shift(@tmp_ary)+ord($string));
	    $string = substr($string,1,99);
	    $online = !$online;
	}
	elsif ($code eq 'r') {
	    ($code,$tmp) = @tmp_ary;
	    @tmp_ary = ($tmp,$code);
	    $online = !$online;
	}
	elsif ($code eq '>') {
	    ($code,$tmp,$string) = unpack("CCa99",$string);
	    if ($_[$[] > $code) {
		$_[$[] += $tmp;
	    }
	}
	elsif ($code eq '2') {
	    $result .= sprintf("%02d",shift(@tmp_ary));
	    $online = !$online;
	}
	elsif ($code eq '3') {
	    $result .= sprintf("%03d",shift(@tmp_ary));
	    $online = !$online;
	}
	elsif ($code eq 'i') {
	    ($code,$tmp) = @tmp_ary;
	    @tmp_ary = ($code+1,$tmp+1);
	}
	else {
	    return "OOPS";
	}
    }
    $result . $string . $after;
}

1;