[103014] users/cal/base-sqlite-portindex/src
cal at macports.org
cal at macports.org
Mon Feb 11 17:29:49 PST 2013
Revision: 103014
https://trac.macports.org/changeset/103014
Author: cal at macports.org
Date: 2013-02-11 17:29:49 -0800 (Mon, 11 Feb 2013)
Log Message:
-----------
Move code related to generating portindices to a package portindex1.0,
encapsulate old Tcl implementation, provide SQLite-based PortIndex
implementation
The PortIndex is currently write-only. SQLite index does not support archive
mode (do we even use that anymore?).
Code querying the PortIndex should (and will) be moved to portindex1.0, too.
Some numbers: When generating the PortIndex from scratch, the runtime is
dominated by the evaluation time of the Portfiles. Both implementations achieve
similar runtime. When few ports need to be updated, SQLite-based is up to 25%
faster.
Modified Paths:
--------------
users/cal/base-sqlite-portindex/src/Makefile.in
users/cal/base-sqlite-portindex/src/port/portindex.tcl
Added Paths:
-----------
users/cal/base-sqlite-portindex/src/portindex1.0/
users/cal/base-sqlite-portindex/src/portindex1.0/Makefile
users/cal/base-sqlite-portindex/src/portindex1.0/portindex.tcl
users/cal/base-sqlite-portindex/src/portindex1.0/sqlite.tcl
users/cal/base-sqlite-portindex/src/portindex1.0/tcl.tcl
Modified: users/cal/base-sqlite-portindex/src/Makefile.in
===================================================================
--- users/cal/base-sqlite-portindex/src/Makefile.in 2013-02-12 01:22:18 UTC (rev 103013)
+++ users/cal/base-sqlite-portindex/src/Makefile.in 2013-02-12 01:29:49 UTC (rev 103014)
@@ -2,6 +2,7 @@
cregistry \
macports1.0 \
port1.0 \
+ portindex1.0 \
package1.0 \
pextlib1.0 \
registry2.0 \
Modified: users/cal/base-sqlite-portindex/src/port/portindex.tcl
===================================================================
--- users/cal/base-sqlite-portindex/src/port/portindex.tcl 2013-02-12 01:22:18 UTC (rev 103013)
+++ users/cal/base-sqlite-portindex/src/port/portindex.tcl 2013-02-12 01:29:49 UTC (rev 103014)
@@ -10,13 +10,12 @@
source [file join "@macports_tcl_dir@" macports1.0 macports_fastload.tcl]
package require macports
package require Pextlib
+package require portindex
+
# Globals
set archive 0
set full_reindex 0
-set stats(total) 0
-set stats(failed) 0
-set stats(skipped) 0
array set ui_options [list]
array set global_options [list]
array set global_variations [list]
@@ -30,146 +29,16 @@
global argv0
puts "Usage: $argv0 \[-adf\] \[-p plat_ver_arch\] \[-o output directory\] \[directory\]"
puts "-a:\tArchive port directories (for remote sites). Requires -o option"
- puts "-o:\tOutput all files to specified directory"
puts "-d:\tOutput debugging information"
puts "-f:\tDo a full re-index instead of updating"
+ puts "-o:\tOutput all files to specified directory"
puts "-p:\tPretend to be on another platform"
+ puts "-s:\tGenerate SQLite-based PortIndex, disables generation of Tcl-based index"
}
-proc pindex {portdir} {
- global target oldfd oldmtime newest qindex fd directory archive outdir stats full_reindex \
- ui_options port_options save_prefix keepkeys
+# default index types is Tcl
+set index_type tcl
- # try to reuse the existing entry if it's still valid
- if {$full_reindex != "1" && $archive != "1" && [info exists qindex([string tolower [file tail $portdir]])]} {
- try {
- set mtime [file mtime [file join $directory $portdir Portfile]]
- if {$oldmtime >= $mtime} {
- set offset $qindex([string tolower [file tail $portdir]])
- seek $oldfd $offset
- gets $oldfd line
- set name [lindex $line 0]
- set len [lindex $line 1]
- set line [read $oldfd $len]
-
- if {[info exists ui_options(ports_debug)]} {
- puts "Reusing existing entry for $portdir"
- }
-
- puts $fd [list $name $len]
- puts -nonewline $fd $line
-
- incr stats(skipped)
-
- # also reuse the entries for its subports
- array set portinfo $line
- if {![info exists portinfo(subports)]} {
- return
- }
- foreach sub $portinfo(subports) {
- set offset $qindex([string tolower $sub])
- seek $oldfd $offset
- gets $oldfd line
- set name [lindex $line 0]
- set len [lindex $line 1]
- set line [read $oldfd $len]
-
- puts $fd [list $name $len]
- puts -nonewline $fd $line
-
- incr stats(skipped)
- }
-
- return
- }
- } catch {*} {
- ui_warn "failed to open old entry for ${portdir}, making a new one"
- }
- }
-
- incr stats(total)
- set prefix {\${prefix}}
- if {[catch {set interp [mportopen file://[file join $directory $portdir] $port_options]} result]} {
- puts stderr "Failed to parse file $portdir/Portfile: $result"
- # revert the prefix.
- set prefix $save_prefix
- incr stats(failed)
- } else {
- # revert the prefix.
- set prefix $save_prefix
- array set portinfo [mportinfo $interp]
- mportclose $interp
- set portinfo(portdir) $portdir
- puts "Adding port $portdir"
- if {$archive == "1"} {
- if {![file isdirectory [file join $outdir [file dirname $portdir]]]} {
- if {[catch {file mkdir [file join $outdir [file dirname $portdir]]} result]} {
- puts stderr "$result"
- exit 1
- }
- }
- set portinfo(portarchive) [file join [file dirname $portdir] [file tail $portdir]].tgz
- cd [file join $directory [file dirname $portinfo(portdir)]]
- puts "Archiving port $portinfo(name) to [file join $outdir $portinfo(portarchive)]"
- set tar [macports::findBinary tar $macports::autoconf::tar_path]
- set gzip [macports::findBinary gzip $macports::autoconf::gzip_path]
- if {[catch {exec $tar -cf - [file tail $portdir] | $gzip -c >[file join $outdir $portinfo(portarchive)]} result]} {
- puts stderr "Failed to create port archive $portinfo(portarchive): $result"
- exit 1
- }
- }
-
- foreach availkey [array names portinfo] {
- # store list of subports for top-level ports only
- if {![info exists keepkeys($availkey)] && $availkey != "subports"} {
- unset portinfo($availkey)
- }
- }
- set output [array get portinfo]
- set len [expr [string length $output] + 1]
- puts $fd [list $portinfo(name) $len]
- puts $fd $output
- set mtime [file mtime [file join $directory $portdir Portfile]]
- if {$mtime > $newest} {
- set newest $mtime
- }
- # now index this portfile's subports (if any)
- if {![info exists portinfo(subports)]} {
- return
- }
- foreach sub $portinfo(subports) {
- incr stats(total)
- set prefix {\${prefix}}
- if {[catch {set interp [mportopen file://[file join $directory $portdir] [concat $port_options subport $sub]]} result]} {
- puts stderr "Failed to parse file $portdir/Portfile with subport '${sub}': $result"
- set prefix $save_prefix
- incr stats(failed)
- } else {
- set prefix $save_prefix
- array unset portinfo
- array set portinfo [mportinfo $interp]
- mportclose $interp
- set portinfo(portdir) $portdir
- puts "Adding subport $sub"
- foreach availkey [array names portinfo] {
- if {![info exists keepkeys($availkey)]} {
- unset portinfo($availkey)
- }
- }
- set output [array get portinfo]
- set len [expr [string length $output] + 1]
- puts $fd [list $portinfo(name) $len]
- puts $fd $output
- }
- }
- }
-}
-
-if {[expr $argc > 8]} {
- print_usage
- exit 1
-}
-
for {set i 0} {$i < $argc} {incr i} {
set arg [lindex $argv $i]
switch -regex -- $arg {
@@ -194,6 +63,8 @@
lappend port_options os.platform $os_platform os.major $os_major os.arch $os_arch
} elseif {$arg == "-f"} { # Completely rebuild index
set full_reindex 1
+ } elseif {$arg == "-s"} { # Use SQLite, disable Tcl index
+ set index_type sqlite
} else {
puts stderr "Unknown option: $arg"
print_usage
@@ -240,41 +111,12 @@
set outdir $directory
}
-puts "Creating port index in $outdir"
-set outpath [file join $outdir PortIndex]
-# open old index for comparison
-if {[file isfile $outpath] && [file isfile ${outpath}.quick]} {
- set oldmtime [file mtime $outpath]
- set newest $oldmtime
- if {![catch {set oldfd [open $outpath r]}] && ![catch {set quickfd [open ${outpath}.quick r]}]} {
- if {![catch {set quicklist [read $quickfd]}]} {
- foreach entry [split $quicklist "\n"] {
- set qindex([lindex $entry 0]) [lindex $entry 1]
- }
- }
- close $quickfd
- }
-} else {
- set newest 0
-}
+portindex::set_portindex_type ${index_type}
-set tempportindex [mktemp "/tmp/mports.portindex.XXXXXXXX"]
-set fd [open $tempportindex w]
-set save_prefix ${macports::prefix}
-foreach key {categories depends_fetch depends_extract depends_build \
- depends_lib depends_run description epoch homepage \
- long_description maintainers name platforms revision variants \
- version portdir portarchive replaced_by license installs_libs} {
- set keepkeys($key) 1
-}
-mporttraverse pindex $directory
-if {[info exists oldfd]} {
- close $oldfd
-}
-close $fd
-file rename -force $tempportindex $outpath
-file mtime $outpath $newest
-mports_generate_quickindex $outpath
+puts "Creating ${index_type} port index in $outdir"
+portindex::update ${outdir} [namespace code {mporttraverse [portindex::callback] $directory}]
+
+array set stats [portindex::statistics]
puts "\nTotal number of ports parsed:\t$stats(total)\
\nPorts successfully parsed:\t[expr $stats(total) - $stats(failed)]\
\nPorts failed:\t\t\t$stats(failed)\
Added: users/cal/base-sqlite-portindex/src/portindex1.0/Makefile
===================================================================
--- users/cal/base-sqlite-portindex/src/portindex1.0/Makefile (rev 0)
+++ users/cal/base-sqlite-portindex/src/portindex1.0/Makefile 2013-02-12 01:29:49 UTC (rev 103014)
@@ -0,0 +1,22 @@
+INSTALLDIR= ${DESTDIR}${datadir}/macports/Tcl/portindex1.0
+
+SRCS= portindex.tcl tcl.tcl sqlite.tcl
+
+include ../../Mk/macports.autoconf.mk
+
+.PHONY: test
+
+all:: pkgIndex.tcl
+
+pkgIndex.tcl: $(SRCS)
+ $(SILENT) ../pkg_mkindex.sh . || ( rm -rf $@ && exit 1 )
+
+clean::
+ rm -f pkgIndex.tcl
+
+install:: all
+ $(INSTALL) -d -o ${DSTUSR} -g ${DSTGRP} -m ${DSTMODE} ${INSTALLDIR}
+ $(SILENT)set -x; for file in ${SRCS}; do \
+ $(INSTALL) -o ${DSTUSR} -g ${DSTGRP} -m 444 $$file ${INSTALLDIR}; \
+ done
+ $(INSTALL) -o ${DSTUSR} -g ${DSTGRP} -m 444 pkgIndex.tcl ${INSTALLDIR}
Property changes on: users/cal/base-sqlite-portindex/src/portindex1.0/Makefile
___________________________________________________________________
Added: svn:eol-style
+ native
Added: users/cal/base-sqlite-portindex/src/portindex1.0/portindex.tcl
===================================================================
--- users/cal/base-sqlite-portindex/src/portindex1.0/portindex.tcl (rev 0)
+++ users/cal/base-sqlite-portindex/src/portindex1.0/portindex.tcl 2013-02-12 01:29:49 UTC (rev 103014)
@@ -0,0 +1,112 @@
+# et:ts=4:tw=80
+# portindex.tcl
+# $Id$
+#
+# Copyright (c) 2004-2013 The MacPorts Project
+# Copyright (c) 2002-2004 Apple Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of Apple Inc. nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# standard package load
+package provide portindex 1.0
+
+package require portindex::tcl 1.0
+package require portindex::sqlite 1.0
+
+namespace eval portindex {
+ # The type of the PortIndex implementation
+ variable portindex_type ""
+
+ # Number of total ports processed in this index operation
+ variable count_total 0
+ # Number of ports that were processed but failed
+ variable count_failed 0
+ # Number of ports that were skipped, because they were current
+ variable count_skip 0
+
+ # Sets the type of the PortIndex. This needs to be called before calling
+ # any other procedure in this namespace. Valid values for type are at the
+ # moment: sqlite, tcl.
+ proc set_portindex_type {type} {
+ variable portindex_type
+
+ switch -exact ${type} {
+ tcl -
+ sqlite {
+ # do nothing, those are valid types
+ }
+ default {
+ error "portindex::set_portindex_type called with invalid type \
+ ${type}. Valid types are: sqlite, tcl."
+ }
+ }
+
+ if {${portindex_type} != ""} {
+ namespace forget ${portindex_type}::*
+ }
+ namespace import ${type}::*
+ set portindex_type ${type}
+ }
+
+ # Increase the number of ports in total. Call this once for every port
+ # processed from the portindex implementation
+ proc inc_total {{amount 1}} {
+ variable count_total
+ incr count_total ${amount}
+ }
+
+ # Increase the number of failed ports. Call this once for every port that
+ # fails to process form the portindex implementation
+ proc inc_failed {{amount 1}} {
+ variable count_failed
+ incr count_failed ${amount}
+ }
+
+ # Increase the number of skipped ports. Call this once from the portindex
+ # implementation for every port you skip because its info seems to be
+ # current.
+ proc inc_skipped {{amount 1}} {
+ variable count_skip
+ incr count_skip ${amount}
+ }
+
+ # Get some statistics about the portindex operation. This may be called
+ # after portindex::finish and will return an array (in list format) with
+ # the fields total, failed and skipped. E.g., you can use this like this:
+ # array set statistics [portindex::statistics]
+ proc statistics {} {
+ variable count_failed
+ variable count_skip
+ variable count_total
+
+ array set statistics {}
+ set statistics(total) ${count_total}
+ set statistics(failed) ${count_failed}
+ set statistics(skipped) ${count_skip}
+
+ return [array get statistics]
+ }
+}
Added: users/cal/base-sqlite-portindex/src/portindex1.0/sqlite.tcl
===================================================================
--- users/cal/base-sqlite-portindex/src/portindex1.0/sqlite.tcl (rev 0)
+++ users/cal/base-sqlite-portindex/src/portindex1.0/sqlite.tcl 2013-02-12 01:29:49 UTC (rev 103014)
@@ -0,0 +1,532 @@
+# vim:et:ts=4:tw=80
+# sqlite.tcl
+# $Id$
+#
+# Copyright (c) 2004-2013 The MacPorts Project
+# Copyright (c) 2002-2004 Apple Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of Apple Inc. nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# standard package load
+package provide portindex::sqlite 1.0
+
+namespace eval portindex::sqlite {
+ # The output directory for the PortIndex
+ variable outdir
+
+ # The output path for the PortIndex
+ variable outpath
+
+ # Temporary portindex file
+ variable tempportindex
+
+ # Copy of ${macports::prefix}
+ variable save_prefix
+
+ # Variable holding the SQLite database connection
+ variable db
+
+ # Timestamp of the last PortIndex update, to find out whether we need to
+ # re-parse a port.
+ variable oldmtime
+
+ # Updates the PortIndex. Consider this to start a transaction, run the Tcl
+ # block given in $script and finish a transaction (which is what it does in
+ # the SQLite variant).
+ namespace export update
+ proc update {outdir script} {
+ variable db
+
+ init ${outdir}
+ db transaction {
+ ${script}
+ }
+ finish
+ }
+
+ # Initialize the database and create the required tables. This is only
+ # called after the database has successfully been opened, so we can assume
+ # the connection to be open. We haven't ensured the file to be writable yet,
+ # though…
+ proc create_database {database} {
+ if {[catch {
+ db eval "
+ CREATE TABLE IF NOT EXISTS $database.portindex_version (
+ version TEXT PRIMARY KEY
+ );
+ DELETE FROM $database.portindex_version;
+ INSERT INTO $database.portindex_version (version) VALUES ('1.0');
+ CREATE TABLE IF NOT EXISTS $database.maintainers (
+ port_id INTEGER NOT NULL
+ , maintainer TEXT NOT NULL
+ , PRIMARY KEY (port_id, maintainer)
+ , FOREIGN KEY (port_id) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE TABLE IF NOT EXISTS $database.platforms (
+ port_id INTEGER NOT NULL
+ , platform TEXT NOT NULL
+ , PRIMARY KEY (port_id, platform)
+ , FOREIGN KEY (port_id) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE TABLE IF NOT EXISTS $database.variants (
+ port_id INTEGER NOT NULL
+ , variant TEXT NOT NULL
+ , PRIMARY KEY (port_id, variant)
+ , FOREIGN KEY (port_id) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE TABLE IF NOT EXISTS $database.categories (
+ port_id INTEGER NOT NULL
+ , category TEXT NOT NULL
+ , PRIMARY KEY (port_id, category)
+ , FOREIGN KEY (port_id) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE TABLE IF NOT EXISTS $database.licenses (
+ port_id INTEGER NOT NULL
+ , license TEXT NOT NULL
+ , PRIMARY KEY (port_id, license)
+ , FOREIGN KEY (port_id) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE TABLE IF NOT EXISTS $database.portindex (
+ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL
+ , port TEXT COLLATE NOCASE UNIQUE NOT NULL
+ , parentport INTEGER
+ , epoch INTEGER NOT NULL
+ , version TEXT NOT NULL
+ , revision INTEGER NOT NULL
+ , homepage TEXT
+ , description TEXT COLLATE NOCASE
+ , long_description TEXT COLLATE NOCASE
+ , portdir TEXT
+ , replaced_by TEXT
+ , installs_libs BOOL
+ , mtime INTEGER
+ , FOREIGN KEY (parentport) REFERENCES portindex (id)
+ ON DELETE CASCADE
+ ON UPDATE CASCADE
+ );
+ CREATE INDEX IF NOT EXISTS $database.portindex_parentport
+ ON portindex (parentport);
+ CREATE INDEX IF NOT EXISTS $database.portindex_portdir
+ ON portindex (portdir, parentport);
+ "
+ } result]} {
+ set sqlerror [db errorcode]
+ ui_error "Error code ${sqlerror} querying database ${database}: ${result}"
+ exit 1
+ }
+ }
+
+ # Initialize this PortIndex generator.
+ # Sets any variables this specific implementation of the portindex needs
+ # and opens a new temporary portindex file.
+ proc init {outdir_param} {
+ package require sqlite3
+
+ variable oldmtime 0
+ variable outdir
+ variable outpath
+ variable save_prefix
+ variable db
+
+ global archive
+
+ if {${archive} == "1"} {
+ error "Archive mode is not supported by the SQLite PortIndex."
+ }
+
+ set outdir ${outdir_param}
+ set outpath [file join ${outdir} PortIndex.db]
+
+ if {[catch {sqlite3 db ${outpath}} result]} {
+ ui_error "error opening database ${outpath}: ${result}"
+ exit 1
+ }
+
+ # set 500ms busy timeout
+ db timeout 500
+
+ # create an in-memory database
+ db eval {
+ ATTACH DATABASE ':memory:' AS tmpdb;
+ }
+ create_database tmpdb
+
+ if {[catch {set version [db onecolumn {SELECT version FROM portindex_version}]} result]} {
+ switch -exact [db errorcode] {
+ 1 {
+ # SQLITE_ERROR, SQL error or missing database
+ if {[regexp {^no such table: portindex_version} $result]} {
+ # Database hasn't been created yet.
+ create_database main
+ }
+ }
+
+ default {
+ ui_error "Error code [db errorcode] querying database: $result"
+ exit 1
+ }
+ }
+ } else {
+ # Create an in-memory copy of the database, for lookup speed.
+ db eval {
+ INSERT INTO tmpdb.portindex SELECT * FROM main.portindex;
+ INSERT INTO tmpdb.variants SELECT * FROM main.variants;
+ INSERT INTO tmpdb.categories SELECT * FROM main.categories;
+ INSERT INTO tmpdb.maintainers SELECT * FROM main.maintainers;
+ INSERT INTO tmpdb.platforms SELECT * FROM main.platforms;
+ INSERT INTO tmpdb.licenses SELECT * FROM main.licenses;
+ }
+ }
+
+ # query portindex for the maximum previous mtime
+ try {
+ set oldmtime [db onecolumn {SELECT MAX(mtime) FROM tmpdb.portindex}]
+ }
+
+ set save_prefix ${macports::prefix}
+ }
+
+ # Insert a list-type field into the portindex database. Examples for
+ # list-type fields are: categories, variants, maintainers, licenses, and
+ # platforms. Parameters are the name of the table holding the list, the
+ # name of the field (both in the portinfo array and in the database table)
+ # and a reference to the portinfo array.
+ proc insert_list {table field portinforef} {
+ variable db
+
+ upvar $portinforef portinfo
+
+ if {![info exists portinfo($field)]} {
+ # if there's not categories, variants, etc.
+ return
+ }
+
+ foreach value $portinfo($field) {
+ db eval "
+ INSERT INTO
+ $table
+ (
+ port_id
+ , $field
+ ) VALUES (
+ :portinfo(id)
+ , :value
+ )
+ "
+ }
+ }
+
+ # Update a list-type field in the portindex database. See insert_list for
+ # examples of list-type fields. Parameters are the name of the table
+ # holding the list, the name of the field (both in the portinfo array and
+ # in the database table) and a reference to the portinfo array.
+ proc update_list {table field portinforef} {
+ variable db
+
+ upvar $portinforef portinfo
+
+ if {![info exists portinfo($field)]} {
+ # we have an empty list
+ # make sure the database is empty for this combination, too
+ db eval "
+ DELETE FROM
+ $table
+ WHERE
+ port_id = :portinfo(id)
+ "
+ return
+ }
+
+ # Get old and new entries to generate a set of diffs
+ set oldentries [db eval "
+ SELECT
+ $field
+ FROM
+ tmpdb.$table
+ WHERE
+ port_id = :portinfo(id)
+ "]
+ set newentries $portinfo($field)
+
+ set added [list]
+ set deleted [list]
+
+ # find out which elements have been removed or added
+ foreach newentry $newentries {
+ if {[lsearch -exact $oldentries $newentry] == -1} {
+ lappend added $newentry
+ }
+ }
+ foreach oldentry $oldentries {
+ if {![lsearch -exact $newentries $oldentry] == -1} {
+ lappend deleted $oldentry
+ }
+ }
+
+ # and delete/add them
+ foreach del $deleted {
+ db eval "
+ DELETE FROM
+ $table
+ WHERE
+ port_id = :portinfo(id)
+ AND $field = :del
+ "
+ }
+ foreach add $added {
+ db eval "
+ INSERT INTO
+ $table
+ (
+ port_id
+ , $field
+ ) VALUES (
+ :portinfo(id)
+ , :add
+ )
+ "
+ }
+ }
+
+ # Helper function to write an entry
+ # Given an array reference to portinfo (portinforef), the mtime of the
+ # portfile and the parent port (if this port is a subport), insert an entry
+ # into the index.
+ proc pindex_write_entry {portinforef mtime {parentport {}}} {
+ variable db
+
+ upvar $portinforef portinfo
+
+ set portinfo(id) [db onecolumn {
+ SELECT
+ id
+ FROM
+ tmpdb.portindex
+ WHERE
+ port = $portinfo(name)
+ }]
+
+ if {$portinfo(id) == ""} {
+ # new entry, just dump it into the database
+ db eval {
+ INSERT INTO
+ portindex
+ (
+ port
+ , parentport
+ , epoch
+ , version
+ , revision
+ , homepage
+ , description
+ , long_description
+ , portdir
+ , replaced_by
+ , installs_libs
+ , mtime
+ ) VALUES (
+ $portinfo(name)
+ , $parentport
+ , $portinfo(epoch)
+ , $portinfo(version)
+ , $portinfo(revision)
+ , $portinfo(homepage)
+ , $portinfo(description)
+ , $portinfo(long_description)
+ , $portinfo(portdir)
+ , $portinfo(replaced_by)
+ , $portinfo(installs_libs)
+ , $mtime
+ )
+ }
+ set portinfo(id) [db last_insert_rowid]
+ insert_list categories category portinfo
+ insert_list licenses license portinfo
+ insert_list maintainers maintainer portinfo
+ insert_list platforms platform portinfo
+ insert_list variants variant portinfo
+ } else {
+ # update the existing entry
+ db eval {
+ UPDATE
+ portindex
+ SET
+ parentport = $parentport
+ , epoch = $portinfo(epoch)
+ , version = $portinfo(version)
+ , revision = $portinfo(revision)
+ , homepage = $portinfo(homepage)
+ , description = $portinfo(description)
+ , long_description = $portinfo(long_description)
+ , portdir = $portinfo(portdir)
+ , replaced_by = $portinfo(replaced_by)
+ , installs_libs = $portinfo(installs_libs)
+ , mtime = $mtime
+ WHERE
+ id = $portinfo(id)
+ }
+ update_list categories category portinfo
+ update_list licenses license portinfo
+ update_list maintainers maintainer portinfo
+ update_list platforms platform portinfo
+ update_list variants variant portinfo
+ }
+ }
+
+ # Helper function to read an entry from the previous PortIndex
+ proc pindex_read_entry {portinforef portname} {
+ variable db
+
+ upvar $portinforef portinfo
+ array set portinfo {}
+
+ # TODO: Query info from the database
+ error "unimplemented"
+ }
+
+ # Callback returned by the portindex::tcl::callback procedure
+ # Actually decides whether to re-evluate a Portfile and writes the index
+ # file
+ proc pindex {portdir} {
+ variable db
+ variable oldmtime
+ variable qindex
+ variable outdir
+ variable save_prefix
+ variable keepkeys
+
+ global directory full_reindex ui_options port_options
+
+ set mtime [file mtime [file join $directory $portdir Portfile]]
+
+ # try to reuse the existing entry if it's still valid
+ if {$full_reindex != "1"} {
+ set port_id [db onecolumn {
+ SELECT
+ id
+ FROM
+ tmpdb.portindex
+ WHERE
+ portdir = $portdir
+ AND parentport = ""
+ }]
+ if {$port_id != ""} {
+ try {
+ if {$oldmtime >= $mtime} {
+ if {[info exists ui_options(ports_debug)]} {
+ puts "Reusing existing entry for $portdir"
+ }
+
+ # Re-using an entry in SQLite-based PortIndex is as easy as
+ # doing nothing.
+ # This means we can also skip the subports
+ portindex::inc_skipped [db onecolumn {
+ SELECT
+ COUNT(*)
+ FROM
+ tmpdb.portindex
+ WHERE
+ portdir = $portdir
+ }]
+
+ return
+ }
+ } catch {*} {
+ ui_warn "Failed to re-use old entry for ${portdir}, making a new one"
+ }
+ }
+ }
+
+ portindex::inc_total
+ set prefix {\${prefix}}
+ if {[catch {set interp [mportopen file://[file join $directory $portdir] $port_options]} result]} {
+ puts stderr "Failed to parse file $portdir/Portfile: $result"
+ # revert the prefix.
+ set prefix $save_prefix
+ portindex::inc_failed
+ } else {
+ # revert the prefix.
+ set prefix $save_prefix
+ array set portinfo [mportinfo $interp]
+ mportclose $interp
+ set portinfo(portdir) $portdir
+ puts "Adding port $portdir"
+
+ pindex_write_entry portinfo $mtime
+ set parentport $portinfo(id)
+
+ # now index this portfile's subports (if any)
+ if {![info exists portinfo(subports)]} {
+ return
+ }
+ foreach sub $portinfo(subports) {
+ portindex::inc_total
+ set prefix {\${prefix}}
+ if {[catch {set interp [mportopen file://[file join $directory $portdir] [concat $port_options subport $sub]]} result]} {
+ puts stderr "Failed to parse file $portdir/Portfile with subport '${sub}': $result"
+ set prefix $save_prefix
+ portindex::inc_failed
+ } else {
+ set prefix $save_prefix
+ array unset portinfo
+ array set portinfo [mportinfo $interp]
+ mportclose $interp
+ set portinfo(portdir) $portdir
+ puts "Adding subport $sub"
+
+ pindex_write_entry portinfo $mtime $parentport
+ }
+ }
+ }
+ }
+
+ # Returns a callback suitable to be passed to mporttraverse, which will
+ # generate the portindex of this specific type.
+ namespace export callback
+ proc callback {} {
+ return [namespace code {pindex}]
+ }
+
+ # Cleanup procedure called after portindex::replace.
+ proc finish {} {
+ variable db
+
+ db eval {
+ DETACH DATABASE tmpdb
+ }
+ db close
+ }
+}
Added: users/cal/base-sqlite-portindex/src/portindex1.0/tcl.tcl
===================================================================
--- users/cal/base-sqlite-portindex/src/portindex1.0/tcl.tcl (rev 0)
+++ users/cal/base-sqlite-portindex/src/portindex1.0/tcl.tcl 2013-02-12 01:29:49 UTC (rev 103014)
@@ -0,0 +1,366 @@
+# vim:et:ts=4:tw=80
+# tcl.tcl
+# $Id$
+#
+# Copyright (c) 2004-2013 The MacPorts Project
+# Copyright (c) 2002-2004 Apple Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of Apple Inc. nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# standard package load
+package provide portindex::tcl 1.0
+
+namespace eval portindex::tcl {
+ # The output directory for the PortIndex
+ variable outdir
+
+ # The output path for the PortIndex
+ variable outpath
+
+ # The quickindex structure containing offsets into the PortIndex tcl script
+ variable qindex
+ array set qindex {}
+
+ # Temporary portindex file
+ variable tempportindex
+
+ # File descriptor pointing to the old temporary portindex, if any
+ variable oldfd -1
+
+ # File descriptor pointing to the new temporary portindex file
+ variable fd
+
+ # Copy of ${macports::prefix}
+ variable save_prefix
+
+ # Timestamp of the most recent modification in the ports tree, to be the
+ # timestamp of the PortIndex
+ variable newest
+
+ # Timestamp of the last PortIndex update, to find out whether we need to
+ # re-parse a port.
+ variable oldmtime
+
+ variable keepkeys
+ array set keepkeys {
+ categories 1
+ depends_fetch 1
+ depends_extract 1
+ depends_build 1
+ depends_lib 1
+ depends_run 1
+ description 1
+ long_description 1
+ homepage 1
+ maintainers 1
+ name 1
+ platforms 1
+ epoch 1
+ version 1
+ revision 1
+ variants 1
+ portdir 1
+ portarchive 1
+ replaced_by 1
+ license 1
+ installs_libs 1
+ }
+
+ # Updates the PortIndex. Consider this to start a transaction, run the
+ # Tcl block given in $script and finish a transaction (which is what it does
+ # in the SQLite variant). It's a little different in the Tcl variant, though.
+ namespace export update
+ proc update {outdir script} {
+ init ${outdir}
+ ${script}
+ finish
+ }
+
+ # Initialize this PortIndex generator.
+ # Sets any variables this specific implementation of the portindex needs
+ # and opens a new temporary portindex file.
+ proc init {outdir_param} {
+ variable fd
+ variable newest
+ variable oldmtime
+ variable oldfd
+ variable outdir
+ variable outpath
+ variable qindex
+ variable save_prefix
+ variable tempportindex
+
+ set outdir ${outdir_param}
+ set outpath [file join ${outdir} PortIndex]
+
+ # start by assuming we have no previous index, and are generating
+ # a fresh one (so the timestamp of the old PortIndex is 0)
+ set newest 0
+
+ # open old index for comparison
+ if {[file isfile $outpath] && [file isfile ${outpath}.quick]} {
+ set oldmtime [file mtime $outpath]
+ set newest $oldmtime
+ if {![catch {set oldfd [open $outpath r]}] &&
+ ![catch {set quickfd [open ${outpath}.quick r]}]} {
+ if {![catch {set quicklist [read $quickfd]}]} {
+ foreach entry [split $quicklist "\n"] {
+ set qindex([lindex $entry 0]) [lindex $entry 1]
+ }
+ }
+ close $quickfd
+ }
+ }
+
+ set tempportindex [mktemp "/tmp/mports.portindex.XXXXXXXX"]
+ set fd [open ${tempportindex} w]
+ set save_prefix ${macports::prefix}
+ }
+
+ # Helper function to write an entry in PortIndex type
+ proc pindex_write_entry {name len line} {
+ variable fd
+
+ puts $fd [list $name $len]
+ puts -nonewline $fd $line
+ }
+
+ # Helper function to read an entry from the previous PortIndex
+ proc pindex_read_entry {nameref lenref lineref portname} {
+ variable oldfd
+ variable qindex
+
+ upvar $nameref name
+ upvar $lenref len
+ upvar $lineref line
+
+ set offset $qindex([string tolower $portname])
+ seek $oldfd $offset
+ gets $oldfd line
+ set name [lindex $line 0]
+ set len [lindex $line 1]
+ set line [read $oldfd $len]
+ }
+
+ # Callback returned by the portindex::tcl::callback procedure
+ # Actually decides whether to re-evluate a Portfile and writes the index
+ # file
+ proc pindex {portdir} {
+ variable fd
+ variable oldfd
+ variable newest
+ variable oldmtime
+ variable qindex
+ variable outdir
+ variable save_prefix
+ variable keepkeys
+
+ global target directory archive stats full_reindex ui_options port_options
+
+ # try to reuse the existing entry if it's still valid
+ if {$full_reindex != "1" &&
+ $archive != "1" &&
+ [info exists qindex([string tolower [file tail $portdir]])]} {
+ try {
+ set mtime [file mtime [file join $directory $portdir Portfile]]
+ if {$oldmtime >= $mtime} {
+ if {[info exists ui_options(ports_debug)]} {
+ puts "Reusing existing entry for $portdir"
+ }
+
+ # Read the old entry, write it to the new file and increase
+ # the skipped counter
+ pindex_read_entry name len line [file tail $portdir]
+ pindex_write_entry $name $len $line
+ portindex::inc_skipped
+
+ # also reuse the entries for its subports
+ array set portinfo $line
+ if {![info exists portinfo(subports)]} {
+ return
+ }
+ foreach sub $portinfo(subports) {
+ pindex_read_entry name len line $sub
+ pindex_write_entry $name $len $line
+ portindex::inc_skipped
+ }
+
+ return
+ }
+ } catch {*} {
+ throw
+ ui_warn "failed to open old entry for ${portdir}, making a new one"
+ }
+ }
+
+ portindex::inc_total
+ set prefix {\${prefix}}
+ if {[catch {set interp [mportopen file://[file join $directory $portdir] $port_options]} result]} {
+ puts stderr "Failed to parse file $portdir/Portfile: $result"
+ # revert the prefix.
+ set prefix $save_prefix
+ portindex::inc_failed
+ } else {
+ # revert the prefix.
+ set prefix $save_prefix
+ array set portinfo [mportinfo $interp]
+ mportclose $interp
+ set portinfo(portdir) $portdir
+ puts "Adding port $portdir"
+ if {$archive == "1"} {
+ if {![file isdirectory [file join $outdir [file dirname $portdir]]]} {
+ if {[catch {file mkdir [file join $outdir [file dirname $portdir]]} result]} {
+ puts stderr "$result"
+ exit 1
+ }
+ }
+ set portinfo(portarchive) [file join [file dirname $portdir] [file tail $portdir]].tgz
+ cd [file join $directory [file dirname $portinfo(portdir)]]
+ puts "Archiving port $portinfo(name) to [file join $outdir $portinfo(portarchive)]"
+ set tar [macports::findBinary tar $macports::autoconf::tar_path]
+ set gzip [macports::findBinary gzip $macports::autoconf::gzip_path]
+ if {[catch {exec $tar -cf - [file tail $portdir] | $gzip -c >[file join $outdir $portinfo(portarchive)]} result]} {
+ puts stderr "Failed to create port archive $portinfo(portarchive): $result"
+ exit 1
+ }
+ }
+
+ foreach availkey [array names portinfo] {
+ # store list of subports for top-level ports only
+ if {![info exists keepkeys($availkey)] && $availkey != "subports"} {
+ unset portinfo($availkey)
+ }
+ }
+ set output "[array get portinfo]\n"
+ set len [string length $output]
+
+ pindex_write_entry $portinfo(name) $len $output
+
+ set mtime [file mtime [file join $directory $portdir Portfile]]
+ if {$mtime > $newest} {
+ set newest $mtime
+ }
+
+ # now index this portfile's subports (if any)
+ if {![info exists portinfo(subports)]} {
+ return
+ }
+ foreach sub $portinfo(subports) {
+ portindex::inc_total
+ set prefix {\${prefix}}
+ if {[catch {set interp [mportopen file://[file join $directory $portdir] [concat $port_options subport $sub]]} result]} {
+ puts stderr "Failed to parse file $portdir/Portfile with subport '${sub}': $result"
+ set prefix $save_prefix
+ portindex::inc_failed
+ } else {
+ set prefix $save_prefix
+ array unset portinfo
+ array set portinfo [mportinfo $interp]
+ mportclose $interp
+ set portinfo(portdir) $portdir
+ puts "Adding subport $sub"
+ foreach availkey [array names portinfo] {
+ if {![info exists keepkeys($availkey)]} {
+ unset portinfo($availkey)
+ }
+ }
+ set output "[array get portinfo]\n"
+ set len [string length $output]
+ pindex_write_entry $portinfo(name) $len $output
+ }
+ }
+ }
+ }
+
+ # Returns a callback suitable to be passed to mporttraverse, which will
+ # generate the portindex of this specific type.
+ namespace export callback
+ proc callback {} {
+ return [namespace code {pindex}]
+ }
+
+ # Replaces the previously live PortIndex using the newly generated one.
+ # This should be atomic, if possible
+ proc finish {} {
+ variable fd
+ variable newest
+ variable oldfd
+ variable outpath
+ variable tempportindex
+
+ if {${oldfd} != -1} {
+ close $oldfd
+ }
+ close $fd
+
+ file rename -force ${tempportindex} ${outpath}
+ file mtime ${outpath} ${newest}
+
+ generate_quickindex ${outpath}
+ }
+
+ # Generate PortIndex.quick storing offsets into PortIndex
+ proc generate_quickindex {outpath} {
+ if {[catch {set indexfd [open ${outpath} r]} result]} {
+ ui_warn "Can't open index file: $::errorInfo"
+ return -code error
+ }
+ if {[catch {set quickfd [open ${outpath}.quick w]} result]} {
+ ui_warn "Can't open quick index file: $::errorInfo"
+ return -code error
+ }
+
+ try {
+ set offset [tell $indexfd]
+ set quicklist ""
+ while {[gets $indexfd line] >= 0} {
+ if {[llength $line] != 2} {
+ continue
+ }
+ set name [lindex $line 0]
+ append quicklist "[string tolower $name] ${offset}\n"
+
+ set len [lindex $line 1]
+ read $indexfd $len
+ set offset [tell $indexfd]
+ }
+ puts -nonewline $quickfd $quicklist
+ } catch {*} {
+ ui_warn "It looks like your PortIndex file $outpath may be corrupt."
+ throw
+ } finally {
+ close $indexfd
+ close $quickfd
+ }
+
+ if {[info exists quicklist]} {
+ return $quicklist
+ } else {
+ ui_warn "Failed to generate quick index for: $outpath"
+ return -code error
+ }
+ }
+}
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20130211/629509bf/attachment-0001.html>
More information about the macports-changes
mailing list