InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/perl/scripts-osu/termcap.pl

Internet Message Format | 1990-02-28 | 4.8 KB

Path: tut.cis.ohio-state.edu!pt.cs.cmu.edu!dsl.pitt.edu!pitt!jupiter!al
From: [e-mail] (Alan Martello)
Newsgroups: comp.lang.perl
Subject: New version of termcap.pl
Message-ID: <[e-mail]>
Date: 24 Feb 90 04:30:36 GMT
Sender: [e-mail]
Reply-To: [e-mail] (Alan Martello)
Distribution: usa
Lines: 187

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.
        [e-mail]           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;