1 files changed, 137 insertions, 0 deletions
diff --git a/web/src/cgi.tcl-1.10/example/creditcard.cgi b/web/src/cgi.tcl-1.10/example/creditcard.cgi
new file mode 100755
index 00000000..a205b452
--- /dev/null
+++ b/web/src/cgi.tcl-1.10/example/creditcard.cgi
@@ -0,0 +1,137 @@
+#!/depot/path/tclsh
+
+package require cgi
+
+cgi_eval {
+    source example.tcl
+
+    set cardtypes {
+	"American Express"
+	"Carte Blanche"
+	"Diners Card"
+	"Discover"
+	"Enroute"
+	"JCB"
+	"Mastercard"
+	"Novus"
+	"Visa"
+    }
+
+    # My own version of the LUHN check
+    proc LUHNFormula {cardnumber} {
+	if {0==[regexp "(.*)(.)$" $cardnumber dummy cardnumber check]} {
+	    user_error "No card number entered"
+	}
+	set evenodd [expr [string length $cardnumber] % 2]
+
+	set sum 0
+	foreach digit [split $cardnumber ""] {
+	    incr sum $digit
+	    if {$evenodd} {
+		incr sum [lindex {0 1 2 3 4 -4 -3 -2 -1 0} $digit]
+	    }
+	    set evenodd [expr !$evenodd]
+	}
+	set computed [expr {(10 - ($sum % 10)) % 10}]
+	if {$computed != $check} {
+	    user_error "Invalid card number.  (Failed LUHN test - try changing last digit to $computed.)"
+	}
+    }    
+
+    # generate digit patterns of length n
+    proc d {n} {
+	for {set i 0} {$i < $n} {incr i} {
+	    append buf {[0-9]}
+	}
+	return $buf
+    }
+
+    cgi_input
+
+    cgi_title "Check Credit Card"
+
+    cgi_body {
+	if {0 == [catch {cgi_import cardtype}]} {
+	    if {[catch {cgi_import cardnumber}]} {
+		user_error "No card number entered"
+	    }
+	    # Save original version for clearer diagnostics
+	    set originalcardnumber [cgi_quote_html $cardnumber]
+
+	    if {[catch {cgi_import expiration}]} {
+		user_error "You must enter an expiration."
+	    }		
+	    if {-1 == [lsearch $cardtypes $cardtype]} {
+		user_error "Unknown card type: $cardtype"
+	    }
+
+	    # Remove any spaces or dashes in card number
+	    regsub -all "\[- ]" $cardnumber "" cardnumber
+
+	    # Make sure that only digits are left
+	    if {[regexp "\[^0-9]" $cardnumber invalid]} {
+		user_error "Invalid character ([cgi_quote_html $invalid]) in credit card number: $originalcardnumber"
+	    }
+
+	    if {$cardtype != "Enroute"} {
+		LUHNFormula $cardnumber
+	    }
+
+	    # Verify correct length and prefix for each card type
+	    switch $cardtype {
+		Visa {
+		    regexp "^4[d 12]([d 3])?$" $cardnumber match
+		} Mastercard {
+		    regexp "^5\[1-5][d 14]$" $cardnumber match
+		} "American Express" {
+		    regexp "^3\[47][d 13]$" $cardnumber match
+		} "Diners Club" {
+		    regexp "^3(0\[0-5]|\[68][d 1])[d 11]$" $cardnumber match
+		} "Carte Blanche" {
+		    regexp "^3(0\[0-5]|\[68][d 1])[d 11]$" $cardnumber match
+		} Discover {
+		    regexp "^6011[d 12]$" $cardnumber match
+		} Enroute {
+		    regexp "^(2014|2149)[d 11]$" $cardnumber match
+		} JCB {
+		    regexp "^(2131|1800)[d 11]$" $cardnumber match
+		    regexp "^3(088|096|112|158|337|528)[d 12]$" $cardnumber match
+		} Novus {
+		    if {[string length $cardnumber] == 16} {
+			set match 1
+		    }
+		}
+	    }
+
+	    if 0==[info exists match] {
+		user_error "Invalid card number: $originalcardnumber"
+	    }
+	    h3 "Your card appears to be valid.  Thanks!"
+	    return
+	}
+
+	cgi_form creditcard {
+	    h3 "Select a card type, enter the card number and expiration."
+	    puts "Card type: "
+	    cgi_select cardtype {
+		foreach t $cardtypes {
+		    cgi_option $t
+		}
+	    }
+	    puts "[nl]Card number: "
+	    cgi_text cardnumber=
+	    puts "(blanks and dashes are ignored)"
+	    
+	    puts "[nl]Expiration: "
+	    cgi_text expiration=
+
+	    br
+	    submit_button "=Confirm purchase"
+	    reset_button
+	    h5 "This script will perform all of the known syntactic
+	    checks for each card type but will not actually contact
+	    a credit bureau.  The expiration field is not presently
+	    checked at all."
+	}
+    }
+}