head	1.2;
access;
symbols
	libdrm-1_0_4:1.2;
locks; strict;
comment	@# @;


1.2
date	2004.04.26.21.46.11;	author fxkuehl;	state Exp;
branches;
next	1.1;

1.1
date	2004.04.23.15.18.16;	author fxkuehl;	state Exp;
branches;
next	;


desc
@Delete or archive old snapshots.
@


1.2
log
@Also archive bleeding-edge snapshots.
@
text
@#!/bin/sh
# -*-tcl-*-
# the next line restarts using tclsh\
exec tclsh "$0" "$@@"

if {$tcl_version < 8.3} {
    puts stderr "TCL version 8.3 or higher is required."
    exit 1
}

# Configuration (from the command line)
set snapshotDir [lindex $argv 0]
set archiveDir [lindex $argv 1]
set archiveInterval 14

if {![file isdirectory $snapshotDir]} {
    puts stderr "Snapshot directory '$snapshotDir' does not exist."
    exit 1
}
if {![file isdirectory $archiveDir]} {
    puts stderr "Archive directory '$archiveDir' does not exist."
    exit 1
}

# Cache the last archived version of each snapshot
array set lastArchived {}

# Helper: map a function to a list
proc map {list function} {
    set result [list]
    foreach elem $list {
	lappend result [eval $function \{$elem\}]
    }
    return $result
}

# Parse a snapshot name, returns a list of name and date
# or an empty list if it's not a valid snapshot name
proc parseSnapName {snapshot} {
    if {![regexp {([a-zA-Z0-9-]*)-([0-9]+)-linux.i386.tar.bz2} $snapshot \
	      all name date]} {
	return {}
    } else {
	# convert date to seconds
	return [list $name [clock scan $date]]
    }
}

proc getLastArchived {name} {
    global lastArchived archiveDir
    if {[catch {set cached $lastArchived($name)}]} {
	# not cached, find it
	set archivedSnaps [map [glob -nocomplain -- \
				    "$archiveDir/$name-*-linux.i386.tar.bz2"] \
			       "file tail"]
	set lastDate 0
	foreach snapshot $archivedSnaps {
	    set parsed [parseSnapName $snapshot]
	    if {[llength $parsed] == 0} continue
	    set thisName [lindex $parsed 0]
	    set thisDate [lindex $parsed 1]
	    if {"$thisName" != "$name"} continue
	    if {$thisDate > $lastDate} {
		set lastDate $thisDate
	    }
	}
	set lastArchived($name) $lastDate
	return $lastDate
    } else {
	return $cached
    }
}

proc archiveSnapshot {name date snapshot} {
    global lastArchived snapshotDir archiveDir

    file rename -- "$snapshotDir/$snapshot" "$archiveDir/$snapshot"

    set lastArchived($name) $date
}

proc removeSnapshot {snapshot} {
    global snapshotDir

    file delete -- "$snapshotDir/$snapshot"
}

# Search snapshot files in the snapshotDir
set snapshots [map [glob -nocomplain --  "$snapshotDir/*-linux.i386.tar.bz2"] \
		   "file tail"]

foreach snapshot $snapshots {
    set parsed [parseSnapName $snapshot]
    if {[llength $parsed] == 0} continue
    set snapName [lindex $parsed 0]
    set snapDate [lindex $parsed 1]
    set today [clock seconds]
    # age of the snapshot in days, keep them for 7 days
    set age [expr {($today - $snapDate) / (3600*24)}]
    if {$age < 7} {
	continue
    }
    # find the last archived version of snapshot
    set lastArch [getLastArchived $snapName]
    # compute the difference of date and lastArchived in days
    set diff [expr {($snapDate - $lastArch) / (3600*24)}]
    # archive one snapshot every 14 days
    if {$diff > 14} {
	archiveSnapshot $snapName $snapDate $snapshot
    } else {
	removeSnapshot $snapshot
    }
}

exit 0
@


1.1
log
@Delete snapshots older than one week, except one snapshot every two weeks
which is kept in snapshots/archive.
@
text
@d11 3
a13 3
# Configuration
set snapshotDir "/home/projects/dri/public_html/snapshots"
set archiveDir "$snapshotDir/archive"
d16 9
d113 3
a115 1
}@