NetNews Usenet Archive 1992 #27/NN_1992_27.iso/spool/comp/lang/perl/7104

Internet Message Format | 1992-11-23 | 6.4 KB

Path: sparky!uunet!nestroy.wu-wien.ac.at!dec4.wu-wien.ac.at!neumann
From: [e-mail] (Gustaf Neumann)
Newsgroups: comp.lang.perl
Subject: Re: Is there a Perl/Wafe gopher client out there?
Date: Mon, 23 Nov 92 15:59:07 MET
Organization: WU-Wien
Lines: 185
Distribution: world
Message-ID: <[e-mail]>
References: <[e-mail]>
NNTP-Posting-Host: dec4.wu-wien.ac.at

In article <[e-mail]> from [23 Nov 92 12:28:35 GMT] you wrote:
 |> Has anyone implemented a Perl gopher (or gopher+) client, or better
 |> still one in Perl which uses the Wafe front end?
 |>
I would not call the following program an elaborate wafe gopher
front end, but you should be able to use it as a starting point.
it handles the most basic gopher codes. Enhancements are welcome.
The program below is a sightly improved version of the wafegopher
program of the wafe distribution. You need wafe 0.92 or better.

-gustaf
=========================================================
#!/usr/local/bin/perl
#
# Date: Mon, Aug 13 1992
# Author: Gustaf Neumann
# Version: 0.92
#
#      Wirtschaftsuniversitaet Wien,
#      Abteilung fuer Wirtschaftsinformatik
#      Augasse 2-6,
#      A-1090 Vienna, Austria
#      [e-mail], [e-mail]
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appears in all copies and that both that
# copyright notice and this permission notice appear in all supporting
# documentation.  This software is provided "as is" without expressed or
# implied warranty.

%privOptions = (
    "p", "gopher port: default is 70",
    "s", "gopher server: default is gopher.micro.umn.edu",
    );

$WafeLib = $ENV{'WAFELIB'} || "/usr/lib/X11/wafe";
require "$WafeLib/perl/wafe.pl";
require 'chat2.pl';

$opt_p = $opt_p || 70; # default gopher port
$gopherServer = $opt_s || "gopher.micro.umn.edu";

@res = (
    'leftBitmap $WafeBitmaps/text.xbm callback {echo r text $l1 $shp}', #0
    'leftBitmap $WafeBitmaps/folder.xbm callback {echo r dir $l1 $shp}', #1
    '', #2
    '', #3
    '', #4
    '', #5
    '', #6
    'leftBitmap $WafeBitmaps/search.xbm callback {global l sel hp;'
              .'set l {$l1};set sel {$sel};set hp {$hp};'
          .'popup searchmenu none}', #7
    'leftBitmap $WafeBitmaps/telnet.xbm callback {echo telnet $shp}', #8
    );

sub listing {
    local($query) = @_;
    local($fail,$string,$conn);
    local($q,$server,$port) =
    ($query =~ /^([^\t]*)\t([^\t]+)\t(\d+)\D?/) ?
        ($1,$2,$3) : ();
    ($server,$port) = ($1,$2) if !$server && $query =~ /^([^\t]+)\t(\d+)\D?/;

    &Xui("sV i$l0 label {retrieving data from $server...}") if $level;

    ($conn = &chat'open_port($server, $port)) || return ("cannot open connection","");
    &chat'print($conn, "$q\r\n");

    $* = 1;
    ($fail,$string) = &chat'expect($conn, 30,
           '^\.\r?\n', '("",$`)',
            'TIMEOUT','("timeout","")');
    $* = 0;
    $string =~ tr/\r//d;
    return($fail,$string);
}

$widget = "waaa";
sub newWidget {
    return $widget++;
}

sub replyList {
    local($t,$level,$query) = @_;
    local($l0,$l1,$vert,$shell,$callback) = ($level-1,$level+1);
    &Xui("sV i$level label {only one window for each level allowed}"), return
    if $blocked{$level};

    $blocked{$level} = 1;
    local($fail,$string) = &listing($query);
    &Xui("sV i$l0 label {$fail}") if $level;
    undef $blocked{$level}, return
    if $fail;

    local($lines) = ($string =~ tr/\n/\n/);
    &Xui("sV i$l0 label {no data available}"),
        undef $blocked{$level}, return
    if $lines == 0 && $level>0;

    if ($level) {
        local($off)=$level*30;
    &Xui("transientShell t$level f0;callback t$level popupCallback position f$l0:$off/$off");
    $shell = "t$level";
    } else {
    $shell = "topLevel";
    }

    &Xui("form ff$level $shell borderWidth 0 $backGround");

    if ($t eq "dir") {
    local($height) = "height 300" if  $lines > 20;
    &Xui("viewport v$level ff$level allowVert true $height borderWidth 0;"
         ."form f$level v$level");
    &Xui("sV i$l0 label {preparing display with $lines lines ...}") if $level;
    foreach((split(/\n/,$string))) {
        if (/^(\d)([^\t]+)\t(.*)$/) {
        local($type,$label,$shp) = ($1,$2,$3);
                ($sel,$hp) = ($1,$2) if $shp =~ /^([^\t]*)\t(.*)$/;
                $shp =~ s/\t/\\t/g;
        local($w) = &newWidget();
        eval '$callback = "'.@res[$type].'"';
        &Xui("command $w f$level label {$label} $vert width 500 borderWidth 0 "
             ."justify left $callback");
        $vert = "fromVert $w";
        }
    }
    $vert = "fromVert v$level";
    &Xui("sV i$l0 label {}") if $level;
    } else {
    local($w) = &newWidget();
        local($height) = "height 300" if $lines > 1;
    &Xui("asciiText $w ff$level width 500 $height scrollVertical always "
            ."$roColors $textFont type string");
    &wafe'tunnel("COMM",$string,"sV $w string \$COMM");
        &wafe'applyActions($w,@textActions);
    $vert = "fromVert $w";
    }
    $callback = $level ?
        "callback {echo free $level;destroyWidget t$level}" : "callback quit";
    &Xui("command q$level ff$level label Quit $buttonAtts $vert $callback;"
        ."label i$level ff$level label {} width 470 $infoColors $vert fromHoriz q$level");
    &Xui("popup t$level none") if $level;
}

&UI( <<"End of TCL");
   transientShell searchmenu topLevel
   callback searchmenu popupCallback positionCursor 45

   dialog searchtext searchmenu label {Search string:} value {} $backGround
   sV searchtext.label $backGround $boldFont
   command searchquit searchtext label {cancel} $buttonAtts \\
          callback {popdown searchmenu}

   action searchtext.value  override \\
       {<Key>Return: exec(global l; global sel; global hp; \\
       echo r dir \$l \$sel\\t\[gV searchtext value\]\\t\$hp) \\
       XtMenuPopdown(searchmenu) }

set sel ""
set l 1
set hp ""
End of TCL

&replyList("dir",0,"\t$gopherServer\t$opt_p");
&Xui("realize");

while(<STDIN>) {
    &replyList($1,$2,$3) if /^r\s+(\S+)\s+(\S+)\s+(.*)$/;
    if (/^telnet\s*(\S*)\t(\S+)\t(.*)$/) {
        local($port) = $3 if $3>0;
        local($title) = "-T 'login $1'" if $1 ne "";
        system("xterm $title -e telnet $2 $port&");
    }
    undef $blocked{$1} if /^free (\d+)/;
}
&wafe'cleanup();

--
Gustaf Neumann          [e-mail], [e-mail]
Vienna University of Economics and Business Administration
Augasse 2-6,  A-1090 Vienna, Austria
Tel: [phone] x4533      Fax: 347-555