zlib: http://pascal.scheffers.net/software/zlib-1.1.1.tar.bz2

* 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

## -*- 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 ]
	} 
    }
}

## -*- 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
	}
    }
}

## -*- 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"


    }
}

## -*- 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
		       
    }
}

## -*- 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
	}
    }
}

## -*- 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);
	    }
	}  
    }
}

## -*- 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
	}
    }
}

#!/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

# # ## ### ##### ######## ############# #####################