ADDED tools/tclfossil/dependencies.txt Index: tools/tclfossil/dependencies.txt ================================================================== --- /dev/null +++ tools/tclfossil/dependencies.txt @@ -0,0 +1,1 @@ +zlib: http://pascal.scheffers.net/software/zlib-1.1.1.tar.bz2 ADDED tools/tclfossil/goals.txt Index: tools/tclfossil/goals.txt ================================================================== --- /dev/null +++ tools/tclfossil/goals.txt @@ -0,0 +1,6 @@ +* use Tcl and the sqlite3 extensions to provide a CLI to fossil +* use Tcl sockets and events to prevent having to use non-portable things like fork +* get fossil on all platforms that support Tcl and SQlite +* allow easy extensibility using Tcl +* provide performance critical parts as TEA extensions +* allow apps to use DVCS by package require fossil ADDED tools/tclfossil/lib/vc/fossil/blob-1.0.tm Index: tools/tclfossil/lib/vc/fossil/blob-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/blob-1.0.tm @@ -0,0 +1,52 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Commands for creating and managing fossil blobs. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require sqlite3 ; # Fossil database access +package require snit ; # OO system. +package require zlib + +package provide vc::fossil::blob 1.0 + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::fossil { + namespace export blob + snit::type blob { + option -data "" + + constructor {args} { + $self configurelist $args + } + + method compress {} { + set data [$self cget -data] + set n [string length $data] + set data [zlib compress $data 9] + set header [binary format I $n] + return $header$data + } + + method decompress {} { + set data [$self cget -data] + binary scan $data I length + return [zlib decompress [string range $data 4 end] $length ] + } + } +} + ADDED tools/tclfossil/lib/vc/fossil/cmd-1.0.tm Index: tools/tclfossil/lib/vc/fossil/cmd-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/cmd-1.0.tm @@ -0,0 +1,43 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Fossil subcommand managment. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require sqlite3 ; # Fossil database access +package require snit ; # OO system. + + +package provide vc::fossil::cmd 1.0 + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::fossil { + namespace export cmd + snit::type cmd { + typevariable commands "" + + typemethod add {command} { + lappend commands $command + + } + + typemethod list {} { + return $commands + } + } +} + ADDED tools/tclfossil/lib/vc/fossil/cmd/clone-1.0.tm Index: tools/tclfossil/lib/vc/fossil/cmd/clone-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/cmd/clone-1.0.tm @@ -0,0 +1,82 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::cmd 1.0 ; # Subcommand management +package require vc::fossil::blob 1.0 + +package provide vc::fossil::cmd::clone 1.0 + +# # ## ### ##### ######## ############# ##################### +## Imports + +namespace import ::vc::fossil::blob + + +# # ## ### ##### ######## ############# ##################### +## + +vc::fossil::cmd add clone + +namespace eval ::vc::fossil::cmd { + proc clone {args} { + if {[ui argc] != 4} { + ui usage "FILE-OR-URL NEW-REPOSITORY" + } + + set local_file [lindex [ui argv] 3] + if {[file exists $local_file]} { + ui panic "file already exists: $local_file" + } + puts "cloning: $args" + package require http + package require sha1 + package require autoproxy + + autoproxy::init + puts [autoproxy::configure] + + proc login_card {userid password message} { + # calculates the login card for the specific user for this msg + + set nonce [sha1::sha1 -hex $message] + set signature [sha1::sha1 -hex $nonce$password] + return "login $userid $nonce $signature\n" + } + + proc http_req {url user password message} { + set login_card [login_card $user $password $message] + blob blob_a -data $login_card$message + set message [blob_a compress] + blob_a destroy + return [http::geturl $url/xfer -binary 1 -query $message -type application/x-fossil] + } + + + set tok [http_req http://www.fossil-scm.org/fossil MJanssen {} clone\n] + http::wait $tok + set zip_body [http::data $tok] + blob blob_a -data $zip_body + set body [blob_a decompress] + blob_a destroy + set lines [split $body \n] + puts $body + puts "Received:\t[string length $body] ([string length $zip_body]) bytes,\t[llength $lines] messages" + + + } +} ADDED tools/tclfossil/lib/vc/fossil/cmd/new-1.0.tm Index: tools/tclfossil/lib/vc/fossil/cmd/new-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/cmd/new-1.0.tm @@ -0,0 +1,44 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::cmd 1.0 ; # Subcommand management +package require vc::fossil::db 1.0 + +package provide vc::fossil::cmd::new 1.0 +vc::fossil::cmd add new + +# # ## ### ##### ######## ############# ##################### +## Imports + + + +# # ## ### ##### ######## ############# ##################### +## + + +namespace eval ::vc::fossil::cmd { + proc new {args} { + if {[ui argc] != 3} { + ui usage "REPOSITORY-NAME" + } + + set filename [file normalize [lindex [ui argv] 2]] + db create_repository $filename + + } +} ADDED tools/tclfossil/lib/vc/fossil/db-1.0.tm Index: tools/tclfossil/lib/vc/fossil/db-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/db-1.0.tm @@ -0,0 +1,54 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Db commands + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require snit ; # OO system. +package require sqlite3 +package require vc::fossil::schema 1.0 ; # Fossil repo schema + +package provide vc::fossil::db 1.0 + +# # ## ### ##### ######## ############# ##################### +## + + + +namespace eval ::vc::fossil { + + snit::type db { + typevariable schemadir [file join [file dirname [info script]] schema] + typevariable dbcmd [namespace current]::sqldb + + typemethod create_repository {filename} { + if {[file exists $filename]} { + ui panic "file already exists: $filename" + } + db init_database $filename [schema repo1] [schema repo2] + } + + typemethod init_database {filename schema args} { + sqlite3 $dbcmd $filename + $dbcmd transaction { + $dbcmd eval $schema + foreach schema $args { + $dbcmd eval $schema + } + } + $dbcmd close + } + } +} ADDED tools/tclfossil/lib/vc/fossil/schema-1.0.tm Index: tools/tclfossil/lib/vc/fossil/schema-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/schema-1.0.tm @@ -0,0 +1,223 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Repository schema's + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require snit ; # OO system. + +package provide vc::fossil::schema 1.0 + +# # ## ### ##### ######## ############# ##################### +## + + + +namespace eval ::vc::fossil { + + snit::type schema { + typemethod repo1 {} { + return { + -- The BLOB and DELTA tables contain all records held in the repository. + -- + -- The BLOB.CONTENT column is always compressed using libz. This + -- column might hold the full text of the record or it might hold + -- a delta that is able to reconstruct the record from some other + -- record. If BLOB.CONTENT holds a delta, then a DELTA table entry + -- will exist for the record and that entry will point to another + -- entry that holds the source of the delta. Deltas can be chained. + -- + CREATE TABLE blob( + rid INTEGER PRIMARY KEY, -- Record ID + rcvid INTEGER, -- Origin of this record + size INTEGER, -- Size of content. -1 for a phantom. + uuid TEXT UNIQUE, -- SHA1 hash of the content + content BLOB -- Compressed content of this record + ); + CREATE TABLE delta( + rid INTEGER PRIMARY KEY, -- Record ID + srcid INTEGER NOT NULL REFERENCES blob -- Record holding source document + ); + CREATE INDEX delta_i1 ON delta(srcid); + + -- Whenever new blobs are received into the repository, an entry + -- in this table records the source of the blob. + -- + CREATE TABLE rcvfrom( + rcvid INTEGER PRIMARY KEY, -- Received-From ID + uid INTEGER REFERENCES user, -- User login + mtime DATETIME, -- Time or receipt + nonce TEXT UNIQUE, -- Nonce used for login + ipaddr TEXT -- Remote IP address. NULL for direct. + ); + + -- Information about users + -- + CREATE TABLE user( + uid INTEGER PRIMARY KEY, -- User ID + login TEXT, -- login name of the user + pw TEXT, -- password + cap TEXT, -- Capabilities of this user + cookie TEXT, -- WWW login cookie + ipaddr TEXT, -- IP address for which cookie is valid + cexpire DATETIME, -- Time when cookie expires + info TEXT, -- contact information + photo BLOB -- JPEG image of this user + ); + + -- The VAR table holds miscellanous information about the repository. + -- in the form of name-value pairs. + -- + CREATE TABLE config( + name TEXT PRIMARY KEY NOT NULL, -- Primary name of the entry + value CLOB, -- Content of the named parameter + CHECK( typeof(name)='text' AND length(name)>=1 ) + ); + + -- Artifacts that should not be processed are identified in the + -- "shun" table. Artifacts that are control-file forgeries or + -- spam can be shunned in order to prevent them from contaminating + -- the repository. + -- + CREATE TABLE shun(uuid UNIQUE); + + -- An entry in this table describes a database query that generates a + -- table of tickets. + -- + CREATE TABLE reportfmt( + rn integer primary key, -- Report number + owner text, -- Owner of this report format (not used) + title text, -- Title of this report + cols text, -- A color-key specification + sqlcode text -- An SQL SELECT statement for this report + ); + } + } + typemethod repo2 {} { + return { + -- Filenames + -- + CREATE TABLE filename( + fnid INTEGER PRIMARY KEY, -- Filename ID + name TEXT UNIQUE -- Name of file page + ); + + -- Linkages between manifests, files created by that manifest, and + -- the names of those files. + -- + -- pid==0 if the file is added by check-in mid. + -- fid==0 if the file is removed by check-in mid. + -- + CREATE TABLE mlink( + mid INTEGER REFERENCES blob, -- Manifest ID where change occurs + pid INTEGER REFERENCES blob, -- File ID in parent manifest + fid INTEGER REFERENCES blob, -- Changed file ID in this manifest + fnid INTEGER REFERENCES filename -- Name of the file + ); + CREATE INDEX mlink_i1 ON mlink(mid); + CREATE INDEX mlink_i2 ON mlink(fnid); + CREATE INDEX mlink_i3 ON mlink(fid); + CREATE INDEX mlink_i4 ON mlink(pid); + + -- Parent/child linkages + -- + CREATE TABLE plink( + pid INTEGER REFERENCES blob, -- Parent manifest + cid INTEGER REFERENCES blob, -- Child manifest + isprim BOOLEAN, -- pid is the primary parent of cid + mtime DATETIME, -- the date/time stamp on cid + UNIQUE(pid, cid) + ); + CREATE INDEX plink_i2 ON plink(cid); + + -- Events used to generate a timeline + -- + CREATE TABLE event( + type TEXT, -- Type of event + mtime DATETIME, -- Date and time when the event occurs + objid INTEGER PRIMARY KEY, -- Associated record ID + uid INTEGER REFERENCES user, -- User who caused the event + bgcolor TEXT, -- Color set by 'bgcolor' property + brbgcolor TEXT, -- Color set by 'br-bgcolor' property + euser TEXT, -- User set by 'user' property + user TEXT, -- Name of the user + ecomment TEXT, -- Comment set by 'comment' property + comment TEXT -- Comment describing the event + ); + CREATE INDEX event_i1 ON event(mtime); + + -- A record of phantoms. A phantom is a record for which we know the + -- UUID but we do not (yet) know the file content. + -- + CREATE TABLE phantom( + rid INTEGER PRIMARY KEY -- Record ID of the phantom + ); + + -- Unclustered records. An unclustered record is a record (including + -- a cluster records themselves) that is not mentioned by some other + -- cluster. + -- + -- Phantoms are usually included in the unclustered table. A new cluster + -- will never be created that contains a phantom. But another repository + -- might send us a cluster that contains entries that are phantoms to + -- us. + -- + CREATE TABLE unclustered( + rid INTEGER PRIMARY KEY -- Record ID of the unclustered file + ); + + -- Records which have never been pushed to another server. This is + -- used to reduce push operations to a single HTTP request in the + -- common case when one repository only talks to a single server. + -- + CREATE TABLE unsent( + rid INTEGER PRIMARY KEY -- Record ID of the phantom + ); + + -- Each baseline or manifest can have one or more tags. A tag + -- is defined by a row in the next table. + -- + -- Wiki pages are tagged with "wiki-NAME" where NAME is the name of + -- the wiki page. Tickets changes are tagged with "ticket-UUID" where + -- UUID is the indentifier of the ticket. + -- + CREATE TABLE tag( + tagid INTEGER PRIMARY KEY, -- Numeric tag ID + tagname TEXT UNIQUE -- Tag name. + ); + INSERT INTO tag VALUES(1, 'bgcolor'); -- TAG_BGCOLOR + INSERT INTO tag VALUES(2, 'comment'); -- TAG_COMMENT + INSERT INTO tag VALUES(3, 'user'); -- TAG_USER + INSERT INTO tag VALUES(4, 'hidden'); -- TAG_HIDDEN + + -- Assignments of tags to baselines. Note that we allow tags to + -- have values assigned to them. So we are not really dealing with + -- tags here. These are really properties. But we are going to + -- keep calling them tags because in many cases the value is ignored. + -- + CREATE TABLE tagxref( + tagid INTEGER REFERENCES tag, -- The tag that added or removed + tagtype INTEGER, -- 0:cancel 1:single 2:branch + srcid INTEGER REFERENCES blob, -- Origin of the tag. 0 for propagated tags + value TEXT, -- Value of the tag. Might be NULL. + mtime TIMESTAMP, -- Time of addition or removal + rid INTEGER REFERENCE blob, -- Baseline that tag added/removed from + UNIQUE(rid, tagid) + ); + CREATE INDEX tagxref_i1 ON tagxref(tagid, mtime); + } + } + } +} ADDED tools/tclfossil/lib/vc/fossil/ui-1.0.tm Index: tools/tclfossil/lib/vc/fossil/ui-1.0.tm ================================================================== --- /dev/null +++ tools/tclfossil/lib/vc/fossil/ui-1.0.tm @@ -0,0 +1,78 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Command line user interface for tclfossil. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.5 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::cmd::clone 1.0 ; # Clone command +package require vc::fossil::cmd::new 1.0 ; # New command + +package provide vc::fossil::ui 1.0 + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::fossil { + snit::type ui { + typevariable argv + typevariable argc + typevariable command + typevariable fSqlTrace + typevariable fUser + + typemethod run {args} { + + # TODO parse options + set argv $args + set argc [llength $args] + + if {$argc < 2} { + ui usage "COMMAND ..." + } + + # TODO better command searching so prefixes work + set command [lindex $argv 1] + set commands [vc::fossil::cmd list] + + if {[lsearch $commands $command] < 0} { + puts "unknown command: $command" + puts {use "help" for more information} + exit 1 + } + vc::fossil::cmd::$command {*}[lrange $argv 1 end] + return + } + + typemethod usage {str} { + puts stderr "Usage: [lrange $argv 0 1] $str" + exit 1 + } + + typemethod panic {str} { + puts stderr "[lindex $argv 0]: $str" + exit 1 + } + + + typemethod argc {} { + return $argc + } + + typemethod argv {} { + return $argv + } + } +} ADDED tools/tclfossil/tf Index: tools/tclfossil/tf ================================================================== --- /dev/null +++ tools/tclfossil/tf @@ -0,0 +1,32 @@ +#!/bin/sh +## -*- tcl -*- \ +exec tclsh "$0" ${1+"$@"} + +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Mark Janssen. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Command line application wrapped around the import packages. + +# # ## ### ##### ######## ############# ##################### +## Requirements, extended package management for local packages. + +::tcl::tm::path add [file normalize [file join [file dirname [info script]] lib]] + +package require Tcl 8.5 ; # Required runtime. +package require vc::fossil::ui ; # Main functionality. + +# # ## ### ##### ######## ############# ##################### +## Execution + +vc::fossil::ui run $::argv0 {*}$argv +exit 0 + +# # ## ### ##### ######## ############# #####################