This is a page for code that would be too long to paste in the [Tcl Chatroom] or #Tcl.

Copy and Paste: A coder's best friend. This technique can save a coder hours maybe even days worth of time, but at what cost?

Another resource you might consider using for this is http://www.nomorepasting.com

----
 /* Copyright 2003 George Peter Staplin
  * Revision 2 
  */

 #include <stdio.h>
 #include <stdlib.h>

 #define check_malloc(s) ({void *r = malloc(s); \
  if (NULL == r) { perror ("unable to malloc"); exit (EXIT_FAILURE); } \
  r; })

 typedef struct pig_s {
  struct pig_s *ar[256];
  int val;
 } Pig;

 Pig *create_pig () {
  Pig *p = check_malloc (sizeof (Pig));
  memset (p, 0, sizeof (Pig));
  return p;
 }

 int pig_get (Pig *p, char *key) {
  while ('\0' != *key) {
   if (NULL == p->ar[*key]) {
    return 0;
   }
   p = p->ar[*key];
   ++key;
  }
  return p->val;
 }

 void pig_insert (Pig *p, char *key, int val) {
  while ('\0' != *key) {
   if (NULL == p->ar[*key]) {
    p->ar[*key] = create_pig();
   }
   p = p->ar[*key];
   ++key;
  }
  p->val = val;
 }

 int main () {
  Pig *p; 
 
  p = create_pig (); 

  pig_insert (p, "abc", 123);
  pig_insert (p, "def", 456);
  pig_insert (p, "abc xyz", 444);

  printf ("1 %d 2 %d 3 %d\n", 
   pig_get (p, "abc"), 
   pig_get (p, "def"), 
   pig_get (p, "abc xyz"));

  return EXIT_SUCCESS; 
 }
----

[AM] A quick hack for automatically creating a parser from the grammar -- 22 dec


 # Experiment with parser generation
 #
 # Simple example:
 # names := name names
 # name := first_name last_name 
 # first_name := STRING
 # last_name  := STRING
 #
 # The input to "parse" is a list of "lexemes"
 #
 proc define { name dependents } {
    global definitions 

    set definitions($name) $dependents
 }

 proc rule { name } {
    global definitions 
    global lexeme
    global end   

    if { $end } return
 
    foreach dep $definitions($name) {
       if { $dep != "STRING" } { 
          rule $dep 
       } else {
          puts "$name: $dep = $lexeme"
          nextLexeme
       }
    }
 }

 proc nextLexeme {} {
    global count
    global input
    global lexeme
    global end

    incr count
    if { $count < [llength $input] } { 
       set lexeme [lindex $input $count]
    } else {
       set end 1
    }
 }
   
 # main --
 #   Just let it happen ...
 #
 global end 
 global count
 global input
 global lexeme

 set end    0
 set count -1
 set input {Arjen Markus My colleague Co Tclers}

 define names {name names}
 define name {first_name last_name} 
 define first_name STRING
 define last_name STRING
 nextLexeme
 rule names
 
----

[GPS]: Here's an example of SMTP via Tcl:

 -- Dec, Tue 16 1:44 gps ~ --   
 $ tclsh8.4
 % set s [socket mail.xmission.com 25]
 sock3
 % fconfigure $s -buffering line     
 % puts $s "MAIL FROM: GeorgePS@XMission.com"
 % gets $s 
 220 mgr1.xmission.com ESMTP Exim 3.35 #1 Tue, 16 Dec 2003 01:44:38 -0700
 % puts $s "RCPT TO: <GeorgePS@XMission.com>"
 % gets $s
 250 <GeorgePS@XMission.com> is syntactically correct
 % puts $s DATA
 % puts $s "I like magic elves and trolls."
 % puts $s ".\nQUIT"
 % flush $s
 % gets $s
 250 <GeorgePS@XMission.com> is syntactically correct
 % close $s
----

 #GPS
 proc blink.me {win i} {
  set cur [$win curselection]
  set fg [$win cget -foreground]
  set bg [$win cget -background] 

  foreach {bg fg} [list $fg $bg] break
  $win configure -foreground $fg
  $win configure -background $bg
  incr i 
  if {$i > 5} return
  after 50 [list blink.me $win $i] 
 }
 pack [listbox .l]; .l insert end Hello World
 bind .l <<ListboxSelect>> {blink.me %W 0}

hmm...  Now that was a little annoying.  It flashes too much.  Let's make it only flash 2 colors or maybe even 3 and then reset.  I think passing it a list of colors might work better.

 #GPS
 proc blink.this {win colList i} {
  set cur [$win curselection]
  foreach {bg fg} $colList break
  $win itemconfigure $cur -selectforeground $fg -selectbackground $bg
  incr i 
  if {$i > 5} {
   $win itemconfigure $cur -selectforeground {} -selectbackground {}
   return
  }
  after 50 [list blink.this $win [list $fg $bg] $i]
 }

 pack [listbox .l]; .l insert end Hello World this is George!
 bind .l <<ListboxSelect>> {blink.this %W {red blue} 0}

----
Abhishek I hope this helps:

 #! /bin/wish8.3
 proc toolbar:make {win arPtr} {
        upvar $arPtr ar
        set i 0; 
        foreach {name mem} [array get ar] {
                set img [lindex $mem 0]
                set cmd [lindex $mem 1]
                pack [button $win.$name -image $img -command $cmd] -side left
                incr i
        }
 }

 proc toolbar:disable {win arPtr key disFile} {
        upvar $arPtr ar
        set img [lindex $ar($key) 0]
        $img read ./$disFile
        $win.$key config -state disabled
 }

 pack [frame .f -relief groove -bd 1]
 set ar(hello) [list [image create photo -file ./hello.gif] {puts "Hello World"}]
 set ar(goodbye) [list [image create photo -file ./goodbye.gif] exit]
 toolbar:make .f ar


 pack [button .b -text "Disable Hello" -command {toolbar:disable .f ar hello ./goodbye.gif}]


----
[jmn] 2003-08-27
Proc size performance


 set bigStuff ""
 for {set i 0} {$i <= 700} {incr i} {
        append bigStuff "set x$i v$i ;\n"
 }
 proc small {args} {
        set v1 [lindex $args 0]
        if {$v1 eq "goFast"} {   v$i ;\n"
                return $v1;
        } else {
                return "slow"
        }
 }
 proc big {args} [string map "@bigStuff@ [list $bigStuff]" {
        set v1 [lindex $args 0]
        if {$v1 eq "goFast"} {  igStuff@ [list $bigStuff]" {
                return $v1;
        } else {
                @bigStuff@
                return "slow"
        }
 }]
 small goFast v1 v2
 small goSlow v1 v2
 big goFast v1 v2
 big goSlow v1 v2
 proc dotimes {{n 1000}} {
        puts "small goFast: [time {small        goFast val1 val2} $n]"
        puts "small goSlow: [time {small        goSlow val1 val2} $n]"
        puts "big   goFast: [time {big  goFast val1 val2} $n]"
        puts "big   goSlow: [time {big  goSlow val1 val2} $n]"
 }