https://gist.github.com/antirez/6ca04dd191bdb82aad9fb241013e88a8

Skip to content
 
[                    ]
All gists Back to GitHub Sign in Sign up
 
Sign in Sign up
{{ message }}

Instantly share code, notes, and snippets.

@antirez

antirez/lmdb.tcl

Created April 28, 2017 15:40

  * Star 324
  * Fork 32

Star
Code Revisions 1 Stars 324 Forks 32
Embed
What would you like to do?
">Embed Embed this gist in your website.
Share Copy sharable link for this gist.
Clone via HTTPS Clone with Git or checkout with SVN using the
repository's web address.
 
Learn more about clone URLs
[<script src="https:/]
 
Download ZIP
LMDB -- First version of Redis written in Tcl
Raw
lmdb.tcl
This file contains bidirectional Unicode text that may be interpreted
or compiled differently than what appears below. To review, open the
file in an editor that reveals hidden Unicode characters. Learn more
about bidirectional Unicode characters
Show hidden characters

 # LVDB - LLOOGG Memory DB
 # Copyriht (C) 2009 Salvatore Sanfilippo <antirez@gmail.com>
 # All Rights Reserved
 # TODO
 # - cron with cleanup of timedout clients, automatic dump
 # - the dump should use array startsearch to write it line by line
 # and may just use gets to read element by element and load the
 whole state.
 # -
 'help','stopserver','saveandstopserver','save','load','reset','keys'
 commands.
 # - ttl with milliseconds resolution 'ttl a 1000'. Check ttl in
 dump!
 # - cluster. Act as master, send write ops to all servers, get from
 one at random. Auto-serialization.
 # - 'hold' and 'continue' command, for sync in cluster mode
 # - auto-sync, consider lazy copy or log of operations to re-read at
 start
 # - client timeout
 # - save dump in temp file.[clock ticks] than rename it
 package require Tclx ;# For [fork]
 array set ::clients {}
 array set ::state {}
 array set ::readlen {}
 array set ::readbuf {}
 array set ::db {}
 array set ::ttl {}
 set ::dirty 0
 set ::lastsaved 0
 set ::listensocket {}
 signal -restart block SIGCHLD
 # the K combinator is using for Tcl object refcount hacking
 # in order to avoid useless object copy.
 proc K {x y} {
 set x
 }
 proc headappend {var e} {
 upvar 1 $var l
 set l [lreplace [K $l [set l {}]] -1 -1 $e]
 }
 proc log msg {
 puts stderr "[clock format [clock seconds]]\] $msg "
 }
 proc warning msg {
 log "*** WARNING: $msg"
 }
 proc writemsg {fd msg} {
 puts -nonewline $fd $msg
 puts -nonewline $fd "\r\n"
 }
 proc resetclient {fd} {
 set ::clients($fd) [clock seconds]
 set ::state($fd) {}
 set ::readlen($fd) 0
 set ::readbuf($fd) {}
 }
 proc accept {fd addr port} {
 resetclient $fd
 fconfigure $fd -blocking 0 -translation binary -encoding binary
 fileevent $fd readable [list readrequest $fd]
 }
 proc readrequest fd {
 if [eof $fd] {
 closeclient $fd
 return
 }
 # Handle bulk read
 if {$::state($fd) ne {}} {
 set buf [read $fd [expr {$::readlen($fd)-[string length $::readbuf
 ($fd)]}]]
 append ::readbuf($fd) $buf
 if {[string length $::readbuf($fd)] >= $::readlen($fd)} {
 set ::readbuf($fd) [string range $::readbuf($fd) 0 end-2]
 lappend ::state($fd) $::readbuf($fd)
 cmd_[lindex $::state($fd) 0] $fd $::state($fd)
 }
 return
 }
 # Handle first line request
 set req [string trim [gets $fd] "\r\n "]
 if {$req eq {}} return
 # Process command
 set args [split $req]
 set cmd [string tolower [lindex $args 0]]
 foreach ct $::cmdtable {
 if {$cmd eq [lindex $ct 0] && [llength $args] == [lindex $ct 1]} {
 if {[lindex $ct 2] eq {inline}} {
 cmd_$cmd $fd $args
 } else {
 set readlen [lindex $args end]
 if {$readlen < 0 || $readlen > 1024*1024} {
 writemsg $fd "protocol error: invalid bulk read length"
 closeclient $fd
 return
 }
 bulkread $fd [lrange $args 0 end-1] $readlen
 }
 return
 }
 }
 writemsg $fd "protocol error: invalid command '$cmd'"
 closeclient $fd
 }
 proc bulkread {fd argv len} {
 set ::state($fd) $argv
 set ::readlen($fd) [expr {$len+2}] ;# Add two bytes for CRLF
 }
 proc closeclient fd {
 unset ::clients($fd)
 unset ::state($fd)
 unset ::readlen($fd)
 unset ::readbuf($fd)
 close $fd
 }
 proc cron {} {
 # Todo timeout clients timeout
 puts "lmdb: [array size ::db] keys, [array size ::clients] clients,
 dirty: $::dirty, lastsaved: $::lastsaved"
 after 1000 cron
 }
 set ::cmdtable {
 {ping 1 inline}
 {quit 1 inline}
 {set 3 bulk}
 {get 2 inline}
 {exists 2 inline}
 {delete 2 inline}
 {incr 2 inline}
 {decr 2 inline}
 {lpush 3 bulk}
 {rpush 3 bulk}
 {save 1 inline}
 {bgsave 1 inline}
 }
 proc okreset {fd {msg OK}} {
 writemsg $fd $msg
 flush $fd
 resetclient $fd
 }
 proc cmd_ping {fd argv} {
 writemsg $fd "PONG"
 flush $fd
 resetclient $fd
 }
 proc cmd_quit {fd argv} {
 okreset $fd
 closeclient $fd
 }
 proc cmd_set {fd argv} {
 set ::db([lindex $argv 1]) [lindex $argv 2]
 incr ::dirty
 okreset $fd
 }
 proc cmd_get {fd argv} {
 if {[info exists ::db([lindex $argv 1])]} {
 set val $::db([lindex $argv 1])
 } else {
 set val {}
 }
 writemsg $fd [string length $val]
 writemsg $fd $val
 flush $fd
 resetclient $fd
 }
 proc cmd_exists {fd argv} {
 if {[info exists ::db([lindex $argv 1])]} {
 set res 1
 } else {
 set res 0
 }
 writemsg $fd $res
 flush $fd
 resetclient $fd
 }
 proc cmd_delete {fd argv} {
 unset -nocomplain -- ::db([lindex $argv 1])
 incr ::dirty
 writemsg $fd "OK"
 flush $fd
 resetclient $fd
 }
 proc cmd_incr {fd argv} {
 cmd_incrdecr $fd $argv 1
 }
 proc cmd_decr {fd argv} {
 cmd_incrdecr $fd $argv -1
 }
 proc cmd_incrdecr {fd argv n} {
 if {[catch {
 incr ::db([lindex $argv 1]) $n
 }]} {
 set ::db([lindex $argv 1]) $n
 }
 incr ::dirty
 writemsg $fd $::db([lindex $argv 1])
 flush $fd
 resetclient $fd
 }
 proc cmd_lpush {fd argv} {
 cmd_push $fd $argv -1
 }
 proc cmd_rpush {fd argv} {
 cmd_push $fd $argv 1
 }
 proc cmd_push {fd argv dir} {
 if {[catch {
 llength $::db([lindex $argv 1])
 }]} {
 if {![info exists ::db([lindex $argv 1])]} {
 set ::db([lindex $argv 1]) {}
 } else {
 set ::db([lindex $argv 1]) [split $::db([lindex $argv 1])]
 }
 }
 if {$dir == 1} {
 lappend ::db([lindex $argv 1]) [lindex $argv 2]
 } else {
 headappend ::db([lindex $argv 1]) [lindex $argv 2]
 }
 incr ::dirty
 okreset $fd
 }
 proc savedb {} {
 set err [catch {
 set fp [open "saved.lmdb" w]
 fconfigure $fp -encoding binary -translation binary
 set search [array startsearch ::db]
 set elements [array size ::db]
 for {set i 0} {$i < $elements} {incr i} {
 set key [array nextelement ::db $search]
 set val $::db($key)
 puts $fp "[string length $key] [string length $val]"
 puts -nonewline $fp $key
 puts -nonewline $fp $val
 }
 close $fp
 set ::dirty 0
 set ::lastsaved [clock seconds]
 } errmsg]
 if {$err} {return $errmsg}
 return {}
 }
 proc backgroundsave {} {
 unset -nocomplain ::dbcopy
 array set ::dbcopy [array get ::db]
 }
 proc cmd_bgsave {fd argv} {
 backgroundsave
 okreset $fd
 }
 proc cmd_save {fd argv} {
 set errmsg [savedb]
 if {$errmsg ne {}} {
 okreset $fd "ER"
 warning "Error trying to save: $errmsg"
 } else {
 okreset $fd
 log "State saved"
 }
 }
 proc loaddb {} {
 set err [catch {
 set fp [open "saved.lmdb"]
 fconfigure $fp -encoding binary -translation binary
 set count 0
 while {[gets $fp len] != -1} {
 set key [read $fp [lindex $len 0]]
 set val [read $fp [lindex $len 1]]
 set ::db($key) $val
 incr count
 }
 log "$count keys loaded"
 close $fp
 } errmsg]
 if {$err} {
 warning "Loading DB from file: $errmsg"
 }
 return $err
 }
 proc main {} {
 log "Server started"
 if {[file exists saved.lmdb]} loaddb
 set ::dirty 0
 set ::listensocket [socket -server accept 6379]
 cron
 }
 main
 vwait forever

@antirez
Copy link
Author

antirez commented Apr 28, 2017 *
edited

This was the first version of Redis... We used it inside our startup,
with Fabio Pitrola. I found it while tweeting about the fact that now
Fabio, the first user of Redis ever together with me, runs an
icecream shop in Barcelona (you should try it btw, http://
gelateriasiciliana.com/). Tried my luck with gmail and there was this
email from 2009!

Note how in a 300 line so of code trow-away there was already most of
Redis main ideas:

 1. Fork() to persist, even if this was an higher level language.
 2. Data structures: this version implements list pop/push
    primitives.
 3. The protocol is the Redis v1 protocol, it's no longer the same
    nowadays, but the prefixed-length idea + human readable is there.
 4. Many names and/or comments in the code even resemble the names of
    modern Redis parts / functions.

So from the POV of programming creation process, it looks like that a
short trow-away can already have hints about how to perform future
developments, by extending each part that can be, in the original
throw away, just a comment.

Email date is: 4 Feb 2009.

Sorry, something went wrong.

@tomas-fp
Copy link

tomas-fp commented Apr 28, 2017

@antirez That's a nice story. Also, the link to "la gelateria" is
invalid, btw.

Sorry, something went wrong.

@antirez
Copy link
Author

antirez commented Apr 28, 2017

Thank you @tomas-fp, I was very happy to discover it since I did not
ever remember at this point if the story I told to people about the
first Tcl version having already lists was true, but actually it was
far more advanced than that: there was already the concept of fork()
for persistency for example, and certain comments and function names
totally resamble modern Redis names / parts.

Sorry, something went wrong.

@agounaris
Copy link

agounaris commented Apr 30, 2017

Lovely, its always amazing to see how a product evolved from a "very
simple" program. Also this implementation reminds me something that
apparently a lot forger these days. People are lost in which
framework to use, which programming language, functional programming,
DDD, TDD, BDD, XXD etc but here we are, redis v1 in tcl doing the job
and moving the development forward. Nearly every successful software
project out there is made with whatever the developer felt
comfortable with at the time of the development.

Thx for sharing this.

Sorry, something went wrong.

@SonOfLilit
Copy link

SonOfLilit commented Apr 30, 2017

If you enjoyed reading this, you might enjoy reading git's first
self-hosted commit: git/git@e83c516

Sorry, something went wrong.

@garrettwilkin
Copy link

garrettwilkin commented Apr 30, 2017

SOMEONE ELSE ON THE INTERNET HAS USED TCL??!?!

I thought I was the only one.

Sorry, something went wrong.

@sammy007
Copy link

sammy007 commented Apr 30, 2017

Potential name conflict https://symas.com/
lightning-memory-mapped-database/

Sorry, something went wrong.

@antirez
Copy link
Author

antirez commented Apr 30, 2017

@sammy007 no problem I've no intention of using the name :-) I just
left the original name, that btw predates the LMDB from Symas, but
anyway the Symas folks could never know there was another LMDB since
was never released in this form before. Later I tought that LMDB was
too much of an acronym and that Redis was much more a name that users
could remember/like, so I changed it with the C rewrite.

Sorry, something went wrong.

@sammy007
Copy link

sammy007 commented May 1, 2017

@antirez Finally I just noticed date at line 2 :)

Sorry, something went wrong.

@cardiffman
Copy link

cardiffman commented May 1, 2017

@garrettwilkin AOL Server uses TCL. https://github.com/aolserver.
Also everyone who uses good old expect is using TCL.

Sorry, something went wrong.

@Snesi
Copy link

Snesi commented May 4, 2017

Dude I will definitely go get some ice-cream there! XD

Sorry, something went wrong.

@aviggiano
Copy link

aviggiano commented May 5, 2017

The idea behind the cmdtable is still the same (now a struct
redisCommand redisCommandTable[])

Sorry, something went wrong.

@devdimi
Copy link

devdimi commented May 11, 2017

This shows that every complex system has evolved from simple system
that works and does something useful.
I was recently reading Systemantics book recommended by some famous
programmers - here is a quote from it.
"A complex system that works is invariably found to have evolved from
a simple system that worked. A complex system designed from scratch
never works and cannot be patched up to make it work. You have to
start over with a working simple system." - John Gall Systemantics
(1975, p.71)

Sorry, something went wrong.

@kavichu
Copy link

kavichu commented May 30, 2017

Awesome

Sorry, something went wrong.

@rafaeleyng
Copy link

rafaeleyng commented Nov 2, 2019

Also the port 6379, still the same

Sorry, something went wrong.

@konfou
Copy link

konfou commented May 15, 2021

Maybe license it under BSD (that Redis uses) or another libre
license? I bet there'll be Tcl hackers that would like play with it.

Sorry, something went wrong.

@ethankent
Copy link

ethankent commented Jun 14, 2022

For anyone getting an ssl error at the above link, adding www appears
to work: https://www.gelateriasiciliana.com

@antirez thanks for sharing. What a little treasure this is!

Sorry, something went wrong.

@antirez
Copy link
Author

antirez commented May 18, 2023

    Maybe license it under BSD (that Redis uses) or another libre
    license? I bet there'll be Tcl hackers that would like play with
    it.

Sure, consider it BSD-licensed.

Sorry, something went wrong.

Sign up for free to join this conversation on GitHub. Already have an
account? Sign in to comment

Footer

 (c) 2023 GitHub, Inc.

Footer navigation

  * Terms
  * Privacy
  * Security
  * Status
  * Docs
  * Contact GitHub
  * Pricing
  * API
  * Training
  * Blog
  * About

You can't perform that action at this time.
You signed in with another tab or window. Reload to refresh your
session. You signed out in another tab or window. Reload to refresh
your session.