[79009] trunk/base/src
jmr at macports.org
jmr at macports.org
Sun May 29 16:23:57 PDT 2011
Revision: 79009
http://trac.macports.org/changeset/79009
Author: jmr at macports.org
Date: 2011-05-29 16:23:56 -0700 (Sun, 29 May 2011)
Log Message:
-----------
allow installing fom a local archive by passing a file:// url as the porturl
Modified Paths:
--------------
trunk/base/src/macports1.0/macports.tcl
trunk/base/src/macports1.0/macports_autoconf.tcl.in
trunk/base/src/package1.0/portarchivefetch.tcl
trunk/base/src/port1.0/fetch_common.tcl
trunk/base/src/port1.0/portutil.tcl
Modified: trunk/base/src/macports1.0/macports.tcl
===================================================================
--- trunk/base/src/macports1.0/macports.tcl 2011-05-29 21:27:53 UTC (rev 79008)
+++ trunk/base/src/macports1.0/macports.tcl 2011-05-29 23:23:56 UTC (rev 79009)
@@ -1129,25 +1129,83 @@
return $result
}
-proc macports::fetch_port {url} {
+proc macports::get_tar_flags {suffix} {
+ switch -- $suffix {
+ .tbz -
+ .tbz2 {
+ return "-j"
+ }
+ .tgz {
+ return "-z"
+ }
+ .txz {
+ return "--use-compress-program [findBinary xz {}] -"
+ }
+ .tlz {
+ return "--use-compress-program [findBinary lzma {}] -"
+ }
+ default {
+ return "-"
+ }
+ }
+}
+
+proc macports::fetch_port {url {local 0}} {
global macports::portdbpath
set fetchdir [file join $portdbpath portdirs]
- set fetchfile [file tail $url]
file mkdir $fetchdir
if {![file writable $fetchdir]} {
return -code error "Port remote fetch failed: You do not have permission to write to $fetchdir"
}
- if {[catch {curl fetch $url [file join $fetchdir $fetchfile]} result]} {
- return -code error "Port remote fetch failed: $result"
+ if {$local} {
+ set fetchfile $url
+ } else {
+ set fetchfile [file tail $url]
+ if {[catch {curl fetch $url [file join $fetchdir $fetchfile]} result]} {
+ return -code error "Port remote fetch failed: $result"
+ }
}
+ set oldpwd [pwd]
cd $fetchdir
- if {[catch {exec [findBinary tar $macports::autoconf::tar_path] -zxf $fetchfile} result]} {
+ # check if this is a binary archive or just the port dir
+ set tarcmd [findBinary tar $macports::autoconf::tar_path]
+ set tarflags [get_tar_flags [file extension $fetchfile]]
+ set qflag ${macports::autoconf::tar_q}
+ set cmdline "$tarcmd ${tarflags}${qflag}xOf {$fetchfile} +CONTENTS"
+ ui_debug "$cmdline"
+ set contents [eval exec $cmdline]
+ if {![catch {set contents [eval exec $cmdline]}]} {
+ set binary 1
+ ui_debug "getting port name from binary archive"
+ # get the portname from the contents file
+ foreach line [split $contents "\n"] {
+ if {[lindex $line 0] == "@name"} {
+ # actually ${name}-${version}_${revision}
+ set portname [lindex $line 1]
+ }
+ }
+ ui_debug "port name is '$portname'"
+ file mkdir $portname
+ cd $portname
+ } else {
+ set binary 0
+ set portname [file rootname $fetchfile]
+ }
+
+ # extract the portfile (and possibly files dir if not a binary archive)
+ ui_debug "extracting port archive to [pwd]"
+ if {$binary} {
+ set cmdline "$tarcmd ${tarflags}${qflag}xOf {$fetchfile} +PORTFILE > Portfile"
+ } else {
+ set cmdline "$tarcmd ${tarflags}xf {$fetchfile}"
+ }
+ ui_debug "$cmdline"
+ if {[catch {eval exec $cmdline} result]} {
return -code error "Port extract failed: $result"
}
- if {[regexp {(.+).tgz} $fetchfile match portdir] != 1} {
- return -code error "Can't decipher portdir from $fetchfile"
- }
- return [file join $fetchdir $portdir]
+
+ cd $oldpwd
+ return [file join $fetchdir $portname]
}
proc macports::getprotocol {url} {
@@ -1163,10 +1221,20 @@
# fetched port will be downloaded to (currently only applies to
# mports:// sources).
proc macports::getportdir {url {destdir "."}} {
+ global macports::extracted_portdirs
set protocol [macports::getprotocol $url]
switch ${protocol} {
file {
- return [file normalize [string range $url [expr [string length $protocol] + 3] end]]
+ set path [file normalize [string range $url [expr [string length $protocol] + 3] end]]
+ if {[file isdirectory $path]} {
+ return $path
+ } else {
+ # need to create a local dir for the exracted port, but only once
+ if {![info exists macports::extracted_portdirs($url)]} {
+ set macports::extracted_portdirs($url) [macports::fetch_port $path 1]
+ }
+ return $macports::extracted_portdirs($url)
+ }
}
mports {
return [macports::index::fetch_port $url $destdir]
@@ -1174,7 +1242,10 @@
https -
http -
ftp {
- return [macports::fetch_port $url]
+ if {![info exists macports::extracted_portdirs($url)]} {
+ set macports::extracted_portdirs($url) [macports::fetch_port $url 0]
+ }
+ return $macports::extracted_portdirs($url)
}
default {
return -code error "Unsupported protocol $protocol"
Modified: trunk/base/src/macports1.0/macports_autoconf.tcl.in
===================================================================
--- trunk/base/src/macports1.0/macports_autoconf.tcl.in 2011-05-29 21:27:53 UTC (rev 79008)
+++ trunk/base/src/macports1.0/macports_autoconf.tcl.in 2011-05-29 23:23:56 UTC (rev 79009)
@@ -44,6 +44,7 @@
variable rsync_path "@RSYNC@"
variable tar_command "@TAR_CMD@"
variable tar_path "@TAR@"
+ variable tar_q "@TAR_Q@"
variable unzip_path "@UNZIP@"
variable xar_path "@XAR@"
}
Modified: trunk/base/src/package1.0/portarchivefetch.tcl
===================================================================
--- trunk/base/src/package1.0/portarchivefetch.tcl 2011-05-29 21:27:53 UTC (rev 79008)
+++ trunk/base/src/package1.0/portarchivefetch.tcl 2011-05-29 23:23:56 UTC (rev 79009)
@@ -65,13 +65,16 @@
default archive.subdir {${subport}}
proc portarchivefetch::filter_sites {} {
- global prefix
+ global prefix porturl
set ret {}
foreach site [array names portfetch::mirror_sites::archive_prefix] {
if {$portfetch::mirror_sites::archive_prefix($site) == $prefix} {
lappend ret $site
}
}
+ if {[file rootname [file tail $porturl]] == [file rootname [file tail [get_portimage_path]]]} {
+ lappend ret [string range $porturl 0 end-[string length [file tail $porturl]]]
+ }
return $ret
}
@@ -257,6 +260,11 @@
# Initialize archivefetch target and call checkfiles.
proc portarchivefetch::archivefetch_init {args} {
+ global porturl portarchivetype
+ # installing straight from a binary archive
+ if {[file rootname [file tail $porturl]] == [file rootname [file tail [get_portimage_path]]] && [file extension $porturl] != ""} {
+ set portarchivetype [string range [file extension $porturl] 1 end]
+ }
return 0
}
Modified: trunk/base/src/port1.0/fetch_common.tcl
===================================================================
--- trunk/base/src/port1.0/fetch_common.tcl 2011-05-29 21:27:53 UTC (rev 79008)
+++ trunk/base/src/port1.0/fetch_common.tcl 2011-05-29 23:23:56 UTC (rev 79009)
@@ -241,8 +241,13 @@
}
foreach site $urllist {
+ if {[string range $site 0 6] == "file://"} {
+ set pingtimes(localhost) 0
+ continue
+ }
+
regexp $hostregex $site -> host
-
+
if { [info exists seen($host)] } {
continue
}
@@ -284,7 +289,11 @@
set pinglist {}
foreach site $urllist {
- regexp $hostregex $site -> host
+ if {[string range $site 0 6] == "file://"} {
+ set host localhost
+ } else {
+ regexp $hostregex $site -> host
+ }
lappend pinglist [ list $site $pingtimes($host) ]
}
Modified: trunk/base/src/port1.0/portutil.tcl
===================================================================
--- trunk/base/src/port1.0/portutil.tcl 2011-05-29 21:27:53 UTC (rev 79008)
+++ trunk/base/src/port1.0/portutil.tcl 2011-05-29 23:23:56 UTC (rev 79009)
@@ -2690,7 +2690,7 @@
# check if we can unarchive this port
proc _archive_available {} {
global subport version revision portvariants ports_source_only workpath \
- registry.path os.platform os.major
+ registry.path os.platform os.major porturl
if {[tbool ports_source_only]} {
return 0
@@ -2704,10 +2704,13 @@
break
}
}
-
- # TODO: also check if porturl points to an archive
- # maybe check if there's an archive available on the server too - this
- # is kind of useless otherwise now that archive == installed image
+ if {!$found && [file rootname [file tail $porturl]] == [file rootname [file tail [get_portimage_path]]] && [file extension $porturl] != ""} {
+ set found 1
+ }
+
+ # TODO: maybe check if there's an archive available on the server - this
+ # is much less useful otherwise now that archive == installed image
+
return $found
}
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.macosforge.org/pipermail/macports-changes/attachments/20110529/cbb9b50e/attachment-0001.html>
More information about the macports-changes
mailing list