From: peter@sugar.hackercorp.com (Peter da Silva) Newsgroups: alt.sources Subject: Browse with TCL interface (part 02/02) Message-ID: <5247@sugar.hackercorp.com> Date: 5 Mar 90 16:54:35 GMT 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@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@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 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 X#include X#include 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 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 X#include X#include 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 . / \ \_.--._/ I haven't lost my mind, it's backed up on tape somewhere! v "Have you hugged your wolf today?" `-_-'