Browse with TCL interface (part 02/02)
Peter da Silva
peter at sugar.hackercorp.com
Tue Mar 6 02:54:35 AEST 1990
Archive-name: browse-tcl/alpha/Part02
[Rewrapped with a fixed version of shar]
#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to comp-sources-unix at uunet.uu.net if you want that tool.
# If this archive is complete, you will see the following message at the end:
# "End of archive 2 (of 2)."
# Contents: Makefile browse.rc ckalloc.c ckalloc.h message.c sample.rc
# system.h tcl_glue.c
# Wrapped by peter at sugar on Mon Mar 5 10:49:50 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Makefile'\"
else
echo shar: Extracting \"'Makefile'\" \(1058 characters\)
sed "s/^X//" >'Makefile' <<'END_OF_FILE'
XSHELL=/bin/sh
X
XCFILES=browse.c screen.c message.c tcl_glue.c tcl_browse.c tcl_get.c ckalloc.c
XOFILES=$(CFILES:.c=.o)
XHFILES=system.h tcl_browse.h ckalloc.h
XTFILES=browse.1 Makefile browse.rc sample.rc $(CFILES) $(HFILES) tcl.pat.vars
XTCLDIR=../tcl
X#
X# Standard USG flags
X#
X#USG# CFLAGS=-g -O -DUSG=1 -I$(TCLDIR)
X#USG# LFLAGS=-g -O
X#USG# LIBS= $(TCLDIR)/tcl.a -ltermlib
X#
X# Standard Xenix flags
X#
XCFLAGS=-O -Ml -DUSG=1 -I$(TCLDIR) -DVOID=int
XLFLAGS=-O -Ml -F 8000
XLIBS= $(TCLDIR)/tcl.a -ltermlib -lx
X#
X# BSD flags
X#
X#BSD# CFLAGS=-g -DBSD=1
X#BSD# LFLAGS=-g -Bstatic
X#BSD# LIBS=-ltermlib
X
Xbrowse: $(OFILES) $(TCLDIR)/tcl.a
X $(CC) $(LFLAGS) $(OFILES) -o browse $(LIBS)
X
X$(TCLDIR)/tcl.a:
X cd $(TCLDIR) ; make tcl.a
X
Xbrowse.shar: $(TFILES)
X shar $(TFILES) > browse.shar
X
Xprint: $(TFILES)
X cpr -r0 $(TFILES) | npr
X
Xtags:
X ctags $(CFILES) $(HFILES)
X
Xclean:
X rm -f $(OFILES) browse core tags
X rm -f MANIFEST~ Part??
X
Xlint:
X lint -I$(TCLDIR) $(CFILES)
X
XMANIFEST: $(TFILES)
X sh -c 'if [ -r MANIFEST ] ;\
X then makekit -m ;\
X else makekit -oMANIFEST $(TFILES) ;\
X fi'
END_OF_FILE
if test 1058 -ne `wc -c <'Makefile'`; then
echo shar: \"'Makefile'\" unpacked with wrong size!
fi
# end of 'Makefile'
fi
if test -f 'browse.rc' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'browse.rc'\"
else
echo shar: Extracting \"'browse.rc'\" \(3334 characters\)
sed "s/^X//" >'browse.rc' <<'END_OF_FILE'
Xset more [get env PAGER]
Xif { [length $more chars] == 0 } { set more more }
X
Xproc perror {} {
X browse message [get error]
X browse bell
X}
X
Xproc target {} {
X set file [get file *]
X if {[length $file chars]==0} {set file [get file .]}
X return $file
X}
X
Xproc key_'j' {} {
X if { ![browse move +1] } { browse bell }
X}
Xproc key_'k' {} {
X if { ![browse move -1] } { browse bell }
X}
Xproc key_':' {} {
X set command [get response :]
X if { [length $command chars] > 0 } {
X if { [catch {eval $command} response] != 0 } {
X browse message Error: $response
X } else {
X if { [length $response chars] > 0 } {
X browse message Response: $response
X }
X }
X }
X}
Xproc key_'!' {} {
X global shellcmd
X set command [get response ! shellcmd]
X if { [length $command chars] > 0 } {
X browse shell $command
X set shellcmd $command
X }
X}
Xproc key_space {} {
X global more
X set file [get file .]
X if { ![browse chdir $file] } {
X set file [target]
X eval [concat browse tag - $file]
X browse message !$more $file
X browse shell [concat $more $file]
X }
X}
Xproc key_'q' {} {
X if { [string compare q [get key -q-]] == 0 } {
X browse exit
X } else {
X browse message
X }
X}
Xproc key_'^J' {} {
X if { [string match *line [get mode]] } { browse redraw }
X}
Xproc key_'d' {} {
X if { [string compare d [get key -d-]] == 0 } {
X set file [target]
X set prompt [concat Delete $file {? }]
X if { [string match {[yY]} [get key $prompt]] } {
X if { ![eval [concat browse delete $file]] } {
X perror
X }
X }
X }
X}
Xproc cdhelp {name def} {
X set dir $name[get response [concat chdir $name] $def]
X if { ![browse chdir $dir] } { perror }
X}
Xproc key_'=' {} { cdhelp {} [get file .] }
Xproc key_'.' {} { cdhelp . {} }
Xproc key_'/' {} { cdhelp / {} }
Xproc key_'~' {} { cdhelp [get env HOME] {} }
Xproc key_'t' {} { eval [concat browse tag / [get file .]] }
Xproc key_'H' {} { browse move [get line home] }
Xproc key_'L' {} { browse move [get line last] }
Xproc key_dollar_sign {} { browse move [get line end] }
Xproc key_'J' {} { browse move [get line end] }
Xproc key_'^' {} { browse move 0 }
Xproc key_'K' {} { browse move 0 }
Xproc key_'M' {} { browse move [expr ([get line home]+[get line last])/2] }
Xproc key_'<' {} { browse mode narrow }
Xproc key_'>' {} { browse mode wide }
Xproc key_'^R' {} { browse rescan }
Xproc key_'^L' {} { browse redraw }
X
Xproc key_'r' {} {
X set file [get file .]
X set prompt [concat Rename $file {to }]
X set new_file [get response $prompt $file]
X if { ![browse rename $file $new_file] } {
X perror
X }
X}
X
Xproc key_'R' {} {
X set files [get file *]
X if { [length files] == 0 } {
X key_'r'
X } else {
X set dir [get response {Move tagged files to }]
X foreach file $files {
X if { ![browse rename $file $dir/$file] } {
X perror
X return
X }
X }
X }
X}
X
Xproc key_'v' {} {
X set command [concat vi [get file .]]
X browse message !$command
X browse shell $command
X}
X
Xproc macro_'#' {} { return [get cwd] }
Xproc macro_'%' {} { return [get file .] }
Xproc macro_'~' {} { return [get env HOME] }
X
Xproc key_'^F' {} {
X browse move [expr {[get line .]+10}]
X}
X
Xproc key_'^B' {} {
X browse move [expr {[get line .]-10}]
X}
X
Xproc key_'+' {} {
X set file [get response {Add file: }]
X if { [length $file chars] > 0 } {
X if { ![browse add $file] } {
X perror
X }
X }
X}
X
Xproc key_'p' {} {
X set files [target]
X eval [concat browse tag /P [target]]
X eval [concat browse tag -T [target]]
X}
END_OF_FILE
if test 3334 -ne `wc -c <'browse.rc'`; then
echo shar: \"'browse.rc'\" unpacked with wrong size!
fi
# end of 'browse.rc'
fi
if test -f 'ckalloc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ckalloc.c'\"
else
echo shar: Extracting \"'ckalloc.c'\" \(824 characters\)
sed "s/^X//" >'ckalloc.c' <<'END_OF_FILE'
X/*
X * VOID *ckalloc(memory)
X * unsigned memory;
X *
X * Allocate memory using malloc. If it fails, call a user-defined routine.
X * This routine returns one of:
X *
X * ALLOC_FATAL (-1) Can't free any more memory, abort.
X * ALLOC_RETRY (0) Try to allocate the memory again.
X */
X#include <stdio.h>
X#include "ckalloc.h"
X
Xstatic int (*lowmem)() = NULL;
X
XVOID *ckalloc(memory)
Xunsigned memory;
X{
X VOID *result;
X VOID *malloc();
X
X do {
X result = malloc(memory);
X } while(result == NULL
X && lowmem
X && (*lowmem)(memory) == ALLOC_RETRY);
X
X if(result == NULL)
X panic("Out of memory: can't malloc %u bytes.\n", memory);
X
X return result;
X}
X
Xint (*setalloc(func))()
Xint (*func)();
X{
X int (*old_lowmem)();
X
X old_lowmem = lowmem;
X lowmem = func;
X return old_lowmem;
X}
X
Xckfree(memory)
Xchar *memory;
X{
X if(memory)
X free(memory);
X}
END_OF_FILE
if test 824 -ne `wc -c <'ckalloc.c'`; then
echo shar: \"'ckalloc.c'\" unpacked with wrong size!
fi
# end of 'ckalloc.c'
fi
if test -f 'ckalloc.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'ckalloc.h'\"
else
echo shar: Extracting \"'ckalloc.h'\" \(127 characters\)
sed "s/^X//" >'ckalloc.h' <<'END_OF_FILE'
X#ifndef VOID
X#define VOID void
X#endif
X
XVOID *ckalloc();
Xint (*setalloc())();
X
X#define ALLOC_FATAL (-1)
X#define ALLOC_RETRY (0)
END_OF_FILE
if test 127 -ne `wc -c <'ckalloc.h'`; then
echo shar: \"'ckalloc.h'\" unpacked with wrong size!
fi
# end of 'ckalloc.h'
fi
if test -f 'message.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'message.c'\"
else
echo shar: Extracting \"'message.c'\" \(1438 characters\)
sed "s/^X//" >'message.c' <<'END_OF_FILE'
X/*
X * message.c, based on the TCL panic.c
X *
X * Source code for the "panic" library procedure.
X *
X * Copyright 1988 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies. The University of California
X * makes no representations about the suitability of this
X * software for any purpose. It is provided "as is" without
X * express or implied warranty.
X */
X
X#include <stdio.h>
X#include <stdlib.h>
X#include <varargs.h>
X
X/*
X *----------------------------------------------------------------------
X *
X * message --
X *
X * Print a message on the browse command line.
X *
X * Results:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
X#ifndef lint
Xvoid
Xmessage(va_alist)
X va_dcl /* char *format, then any number of additional
X * values to be printed under the control of
X * format. This is all just the same as you'd
X * pass to printf. */
X{
X char *format;
X va_list args;
X extern int display_up;
X
X cmdline();
X va_start(args);
X format = va_arg(args, char *);
X (void) vfprintf(stdout, format, args);
X if(!display_up) putchar('\n');
X (void) fflush(stdout);
X}
X#else
X/* VARARGS1 */
X/* ARGSUSED */
Xvoid
Xmessage(format)
X char *format;
X{
X return;
X}
X#endif /* lint */
X
END_OF_FILE
if test 1438 -ne `wc -c <'message.c'`; then
echo shar: \"'message.c'\" unpacked with wrong size!
fi
# end of 'message.c'
fi
if test -f 'sample.rc' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'sample.rc'\"
else
echo shar: Extracting \"'sample.rc'\" \(1147 characters\)
sed "s/^X//" >'sample.rc' <<'END_OF_FILE'
Xproc key_'^K' {} {
X browse message {Edit key }
X set key [get key]
X set func key_[get keyname $key]
X set file [get env HOME]/.function
X if { [length [info procs $func] ] != 0 } {
X set def [list proc $func {} [info body $func]]
X } else {
X set def [list proc $func {} { ... }]
X }
X print $def\n $file
X browse message !vi $file
X browse shell [concat vi $file]
X source $file
X}
X
Xproc save {file args} {
X if { [length $args chars] == 0 } {
X print "# *** all procs ***" $file
X print \n $file append
X set args [info procs]
X } else {
X print [concat {#} $args] $file
X print \n $file append
X }
X foreach proc $args {
X set def [list proc $proc [info args $proc] [info body $proc]]
X print \n$def\n $file append
X }
X}
X
Xset helpfile [get env HOME]browse.help
X
Xproc key_'?' {} {
X global helpfile more
X set key [get keyname [get key {Help on what key (? for all)? }]]
X if { [string compare '?' $key] == 0 } {
X browse message !$more $helpfile
X browse shell [concat $more $helpfile]
X } else {
X set line [exec grep ^$key $helpfile]
X if { [length $line chars] > 0 } {
X browse message $line
X } else {
X browse message {No help available on} $key
X }
X }
X}
X
END_OF_FILE
if test 1147 -ne `wc -c <'sample.rc'`; then
echo shar: \"'sample.rc'\" unpacked with wrong size!
fi
# end of 'sample.rc'
fi
if test -f 'system.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'system.h'\"
else
echo shar: Extracting \"'system.h'\" \(526 characters\)
sed "s/^X//" >'system.h' <<'END_OF_FILE'
X/* system type */
X
X#ifndef BSD
X# if defined(sun) || defined(sun3)
X# define BSD 1
X# endif
X#endif
X
X#ifndef USG
X# ifdef L_ctermid
X# define USG 1
X# endif
X# ifdef M_XENIX
X# define USG 1
X# endif
X#endif
X
X#ifdef BSD
X# undef USG
X#endif
X
X#ifdef USG
X# define rindex strrchr
X# ifdef M_XENIX
X# define GETCWD
X# define SIGNAL int
X# else
X# define minor(i) ((i)&0xFF)
X# define major(i) minor((i)>>8)
X# define SIGNAL void
X# endif
X#else
X# ifdef BSD
X# define SIGNAL void
X# else
X# define SIGNAL int
X# include <whoami.h>
X# endif
X#endif
X
END_OF_FILE
if test 526 -ne `wc -c <'system.h'`; then
echo shar: \"'system.h'\" unpacked with wrong size!
fi
# end of 'system.h'
fi
if test -f 'tcl_glue.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl_glue.c'\"
else
echo shar: Extracting \"'tcl_glue.c'\" \(2533 characters\)
sed "s/^X//" >'tcl_glue.c' <<'END_OF_FILE'
X/* TCL stuff for Browse */
X#include <stdio.h>
X#include <setjmp.h>
X#include <tcl.h>
X#include "tcl_browse.h"
X
XTcl_Interp *interp = NULL;
X
Xextern int cmdBrowse();
Xextern int cmdGet();
X
XFormat(cmdc, cmdv, interp)
Xint cmdc;
Xstruct subcmd *cmdv;
XTcl_Interp *interp;
X{
X char buffer[256];
X
X strcpy(buffer, cmdv->name);
X while(--cmdc) {
X ++cmdv;
X strcat(buffer, " ");
X strcat(buffer, cmdv->name);
X }
X Tcl_Return(interp, buffer, TCL_VOLATILE);
X return TCL_OK;
X}
X
XHandle(cmdc, cmdv, interp, argc, argv)
Xint cmdc;
Xstruct subcmd *cmdv;
XTcl_Interp *interp;
Xint argc;
Xchar **argv;
X{
X char *err;
X char *name;
X char *args;
X
X err = "wrong # args";
X name = "subcommand";
X args = "args";
X
X if(argc < 2)
X goto error;
X
X while(cmdc > 0) {
X if(strcmp(argv[1], cmdv->name) == 0) {
X int result;
X extern int intrup;
X
X name = cmdv->name;
X args = cmdv->args;
X if(argc < cmdv->min+2
X || (cmdv->max != -1 && argc > cmdv->max+2))
X goto error;
X result = (*cmdv->func)(interp, argc-2, argv+2);
X if(intrup) {
X result = TCL_ERROR;
X Tcl_Return(interp, "Interrupted", TCL_STATIC);
X }
X return result;
X }
X cmdv++;
X cmdc--;
X }
X err = "unknown subcommand";
Xerror:
X sprintf(interp->result, "%s: should be \"%.50s %s %s\"",
X err, argv[0], name, args);
X return TCL_ERROR;
X}
X
Xtcl_panic(bytes)
Xint bytes;
X{
X cmdline();
X printf("Out of memory allocating %d bytes\n", bytes);
X tcl_end();
X tend();
X exit(1);
X}
X
X#define BACKUP "proc key_'^Z' {} {browse exit 0}"
X
Xtcl_init()
X{
X int read_browse_rc = 0;
X
X setalloc(tcl_panic);
X
X interp = Tcl_CreateInterp();
X Tcl_CreateCommand(interp, "browse",
X cmdBrowse, (ClientData) "browse", NULL);
X Tcl_CreateCommand(interp, "get",
X cmdGet, (ClientData) "get", NULL);
X
X if(Tcl_Eval(interp, BACKUP, 0, 0) != TCL_OK) {
X fprintf(stderr, "%s\n", interp->result);
X fprintf(stderr, "(error evaluating %s)\n", BACKUP);
X return 0;
X }
X
X if(Tcl_Eval(interp, "source /etc/browse.rc", 0, 0) == TCL_OK)
X read_browse_rc = 1;
X
X if(Tcl_Eval(interp, "source [get env BROWSERC]", 0, 0) == TCL_OK)
X read_browse_rc = 1;
X else if(Tcl_Eval(interp, "source [get env HOME]/.browserc", 0, 0) == TCL_OK)
X read_browse_rc = 1;
X
X if(!read_browse_rc) {
X fprintf(stderr,
X "Could not read /etc/browse.rc, $HOME/.browserc, or $BROWSERC!");
X return 0;
X }
X
X return 1;
X}
X
Xtcl_end()
X{
X if(interp)
X Tcl_DeleteInterp(interp);
X}
X
Xtcl_call(buffer, size)
Xchar *buffer;
X{
X int result;
X
X result = Tcl_Eval(interp, buffer, 0, (char **)0) == TCL_OK;
X strncpy(buffer, interp->result, size);
X buffer[size-1] = 0;
X return result;
X}
END_OF_FILE
if test 2533 -ne `wc -c <'tcl_glue.c'`; then
echo shar: \"'tcl_glue.c'\" unpacked with wrong size!
fi
# end of 'tcl_glue.c'
fi
echo shar: End of archive 2 \(of 2\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked both archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
_--_|\ Peter da Silva <peter at sugar.hackercorp.com>.
/ \
\_.--._/ I haven't lost my mind, it's backed up on tape somewhere!
v "Have you hugged your wolf today?" `-_-'
More information about the Alt.sources
mailing list