Script Junkie
Client-Side Programming with TCL
By Chris Baron
Web Techniques, December 1997

Web Techniques grants permission to use these listings for private or 
commercial use provided that credit to Web Techniques and the author is 
maintained within the comments of the source. For questions, contact
editors@web-techniques.com.

LISTING ONE



# Draggable Text Tclet
# Adapted from the example on the SunLabs web site
# http://www.sunlabs.com/research/tcl/plugin/applets.html
#
proc dragstart {w x y} {
    global draglocation
    catch {unset draglocation}
    set draglocation(obj) [$w find closest $x $y]
    set draglocation(x) $x
    set draglocation(y) $y
}
proc dragit {w x y} {
    global draglocation
    if {"$draglocation(obj)" != ""} {
        set dx [expr $x - $draglocation(x)]
        set dy [expr $y - $draglocation(y)]
        $w move $draglocation(obj) $dx $dy
        set draglocation(x) $x
        set draglocation(y) $y
    }
}
canvas .c -bg $embed_args(background) \
                -width $embed_args(width) -height $embed_args(height)
.c create text 80 50 -text $embed_args(text1) \
                -font *-times-bold-r-*-24-* \
           -tags {movable color=red} -fill $embed_args(color1)
.c create text 200 100 -text $embed_args(text2) \
                -font *-times-medium-i-*-24-* \
           -tags {movable color=blue} -fill $embed_args(color2)
.c bind movable <Button-1> {dragstart %W %x %y}
.c bind movable <B1-Motion> {dragit %W %x %y}
pack .c




LISTING TWO



<HTML><HEAD><TITLE>Hello Tcl</TITLE></HEAD>
<BODY>
<H1>Tclet Demo Dragable Text</H1>
<P>
<p>
<embed src=hellodrag.tcl width=400 height=400
        background="Azure1"
        text1="Hello World!" color1="Firebrick1"
        text2="I love Tcl!" color2="SeaGreen">

</BODY></HTML>
LISTING THREE



# Request the "Outside" security policy if we are running inside a 
browser:
if {[info exists embed_args]} {
    if {[catch {package require Outside} msg]} {
        error "Failed to get \"Outside\" policy: $msg"
    }
}
# What separates items in the data?
if {[info exists embed_args(separators)]} {
    set itemseparators $embed_args(separators)
} else {
    set itemseparators ","
}
# Set data file name
if {[info exists embed_args(database)]} {
    set datafile $embed_args(database)
} else {
    error "No database parameter set in <EMBED> statement"
}



LISTING FOUR


# Phase 1: ask for password to connect to site.
proc phase1 {} {
    label .passwordLabel -text "Please enter the password in the space 
below:"
    entry .password -textvariable password -takefocus 1 -show *
    button .passwordOK -text OK -command sendPassword
    button .passwordAbort -text Abort -command exit
    bind .password <Return> sendPassword
    pack .passwordLabel -fill x
    pack .password -fill x
    pack .passwordOK .passwordAbort -side left -fill x
}
LISTING FIVE


#!/usr/bin/perl
#
# Simple CGI "server" for the WebTechniques Tclet demo
# N.B. no data checking is done here everything is done
# in the Tclet
#
# written by Chris Baron for WebTechniques Magazine
#
$password = 'froboz';
$db_dir = '';

use CGI; # use the CGI.pm module 
         # http://www-
genome.wi.mit.edu/ftp/distribution/software/WWW/
$| = 1;  # turn off buffering

print "content-type: text/plain\n\n";  # all we send is plain text
$f = new CGI; # get form data
if ($f->param('password') ne $password) { &error_exit; } # check pw
if ($f->param('action') eq 'fetch') { &fetch_db; }
elsif ($f->param('action') eq 'update') { &update_db; }
else { &error_exit; }
exit; # end of main program

sub fetch_db {
  if ($f->param('database') eq '') { &error_exit; }
  open (DATABASE, $db_dir.$f->param('database')) || &error_exit;
  while (<DATABASE>) { print; }
  close DATABASE;
}

sub update_db {
  if ($f->param('database') eq '') { &error_exit; }
  @records = $f->param('data');
  # we should lock database here
  open (DATABASE, '>'.$db_dir.$f->param('database')) || &error_exit;
  foreach (@records) { 
     if ($_) { print DATABASE $_, "\n"; }
  }
  close DATABASE;
  # unlock database here
  print "OK\n";
}

sub error_exit {
   print "Error\n";
   exit;
}