From: neumann@dec4.wu-wien.ac.at (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
Distribution: world
NNTP-Posting-Host: dec4.wu-wien.ac.at

In article <1992Nov23.122835.9289@meiko.com> 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
#      neumann@wu-wien.ac.at, nusser@wu-wien.ac.at
#
# 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          neumann@dec4.wu-wien.ac.at, neumann@awiwuw11.bitnet
Vienna University of Economics and Business Administration 
Augasse 2-6,  A-1090 Vienna, Austria		
Tel: +43 (222) 31-336 x4533  	Fax: 347-555

Newsgroups: comp.lang.perl