Registration has been disabled. Blocking over 500 spammers has become too much. If you would like to join this forum, send a request to support@raspberrybasic.org.
Recent Posts
One valuable side-effect of all these add-ons being themselves coded in BASIC
ScriptBasic core hasn't changed since 2005.
Glad you're hanging in there keeping BASIC in the forefront.
requires gui
var userdb
defer: auth
{
kind: "edit",
bounds: "edit1.left, lbl2.top, parent.width-20, top+24",
name: "edit2",
max-text: 32,
password-char: "*",
return-pressed: ' auth ,
text-changed: ( "lbl0" g:child "" g:text drop )
} g:new constant edit2-hide-passwd
{
kind: "edit",
bounds: "edit1.left, lbl2.top, parent.width-20, top+24",
name: "edit2",
max-text: 32,
password-char: "",
return-pressed: ' auth ,
text-changed: ( "lbl0" g:child "" g:text drop )
} g:new constant edit2-show-passwd
: alternator \ a -- a[0]
a:shift dup >r
a:push drop r> ;
[ ` edit2-show-passwd ` , ` edit2-hide-passwd ` ] ' alternator curry: next-state
\ auth states
0 constant NOT-FOUND
1 constant USER-PASSWD-MATCH
2 constant USER-PASSWD-FAIL
: auth-from-db \ id passwd -- state
s:len 0 n:= if
2drop
USER-PASSWD-FAIL
;;
then
>r >r
userdb @ "by-id" r> 1 a:close db:bind-exec[]
a:len 0 n:> if
a:open
"salt" m:@ r> swap 10000 cr:genkey
swap "key" m:@ nip b:= if
USER-PASSWD-MATCH
else
USER-PASSWD-FAIL
then
else
drop
rdrop
NOT-FOUND
then
nip ;
: authenticate
"edit2" g:child g:text? >r
"edit1" g:child g:text? r> auth-from-db
[ ( "lbl0" g:child "User not found!" g:text ) ,
( "Authenticated!" . cr bye ) ,
( "lbl0" g:child "User and password don't match!" g:text ) ] swap
caseof drop ;
' authenticate w:is auth
: init
"mytest.db" f:slurp "No database" thrownull
db:open
\ make a prepared statement
"SELECT * FROM user WHERE id=? LIMIT 1" "by-id" db:prep-name
userdb ! "edit1" g:child g:focus ;
{
kind: "win",
buttons: 5,
native-title-bar: false,
title: "Login",
wide: 520,
high: 220,
resizable: false,
center: true,
init: ' init ,
children:
[
{
kind: "box",
name: "frame",
bounds: "0, 0, parent.width, parent.height",
bg: "gray",
children:
[
{
kind: "image",
bounds: "parent.left+10, parent.top+10, left+128, top+128",
img: "8thlogo.png",
name: "logo"
},
{
kind: "label",
fg: "red",
font: 20,
label: "",
bounds: "logo.right+20, parent.top+10, parent.width-10, top+24 ",
justify: ["hcenter"],
name: "lbl0"
},
{
kind: "label",
label: "Username:",
bounds: "logo.right+20, lbl0.bottom+20, left+80, top+24 ",
name: "lbl1"
},
{
kind: "edit",
bounds: "lbl1.right+10, lbl1.top, parent.width-20, top+24",
name: "edit1",
max-text: 32,
return-pressed: ( "edit2" g:child g:focus drop ),
text-changed: ( "lbl0" g:child "" g:text drop )
},
{
kind: "label",
label: "Password:",
bounds: "lbl1.left, lbl1.bottom+10, left+80, top+24",
name: "lbl2"
},
{
kind: "edit",
bounds: "edit1.left, lbl2.top, parent.width-20, top+24",
name: "edit2",
max-text: 32,
password-char: "*",
return-pressed: ' authenticate ,
text-changed: ( "lbl0" g:child "" g:text drop )
},
{
kind: "toggle",
label: "Show password",
adjustwidth: true,
bounds: "edit1.left, lbl2.bottom+20, left+100, top+24",
name: "toggle",
click: ( "edit2" g:child g:text? >r "frame" g:child "edit2" g:-child next-state g:+child "edit2" g:child r> g:text drop )
},
{
kind: "btn",
label: "Login",
bg: "darkgray",
bounds: "lbl2.left, lbl2.bottom+60, edit1.right, top+30",
name: "button",
tooltip: "Login to account",
click: ' authenticate
}
]
}
]
} g:new var, gui
: app:main
( userdb @ db:close ) onexit ;
"Creating a database and adding data:\n" .
\ remove previous db:
"mytest.db" f:rm
\ open a database:
"mytest.db" db:open "Could not create database" thrownull nip
\ create a table
"CREATE TABLE user (id PRIMARY KEY, key, salt)" db:exec
\ make a prepared statement
"INSERT INTO user VALUES (?, ?, ?);" "insert" db:prep-name
: build-params \ id passwd -- a
cr:uuid >r
r@ 10000 cr:genkey
r>
3 a:close ;
\ insert into table using a parameterized statement
\ You could use t:err? to get map of error information
"insert" "jalih" "pa$$w0rd!" build-params null db:bind-exec
"insert" "guest" "guest" build-params null db:bind-exec
"insert" "john" "hard-passwd" build-params null db:bind-exec
"insert" "air" "crack-this" build-params null db:bind-exec
\ and close the database
"All done!\n" .
db:close
bye