From 06ff92efad0e3bf8226ccdebfef3d05ba7142f43 Mon Sep 17 00:00:00 2001 From: Joshua Root Date: Thu, 25 Jun 2026 11:36:22 +1000 Subject: [PATCH] Allow deferred loading of code for running targets A Portfile interpreter created by mportopen will only end up actually executing a subset of all targets, and may not execute any. Therefore, splitting the code for running targets from that which is needed just to parse the Portfile improves the speed of mportopen and reduces the memory used by each open mport (which can really add up when installing ports with large dependency graphs). Initially only the portfetch code has been split, creating the new portfetch_run package. --- src/package1.0/portarchivefetch.tcl | 2 +- src/port1.0/Makefile.in | 8 +- src/port1.0/portfetch.tcl | 602 +--------------------------- src/port1.0/portfetch_run.tcl | 577 ++++++++++++++++++++++++++ src/port1.0/portmirror.tcl | 24 +- src/port1.0/portutil.tcl | 14 + 6 files changed, 622 insertions(+), 605 deletions(-) create mode 100644 src/port1.0/portfetch_run.tcl diff --git a/src/package1.0/portarchivefetch.tcl b/src/package1.0/portarchivefetch.tcl index fc2885a6e..a6a86a035 100644 --- a/src/package1.0/portarchivefetch.tcl +++ b/src/package1.0/portarchivefetch.tcl @@ -476,7 +476,7 @@ proc portarchivefetch::fetchfiles {{async no} args} { write_statefile target "org.macports.${target}" $target_state_fd } # Cancel any async distfile fetch that may be in progress - portfetch::_async_cleanup + catch {portfetch::_async_cleanup} return 0 } if {[tbool ports_binary_only] || [_archive_available]} { diff --git a/src/port1.0/Makefile.in b/src/port1.0/Makefile.in index 3e2745214..8bf7669ce 100644 --- a/src/port1.0/Makefile.in +++ b/src/port1.0/Makefile.in @@ -12,7 +12,8 @@ SRCS= port.tcl portchecksum.tcl portconfigure.tcl portextract.tcl \ portlint.tcl portclean.tcl porttest.tcl portactivate.tcl portbump.tcl \ portdeactivate.tcl portstartupitem.tcl porttrace.tcl portlivecheck.tcl \ portdistcheck.tcl portmirror.tcl portload.tcl portunload.tcl portreload.tcl \ - portdistfiles.tcl fetch_common.tcl portsandbox.tcl + portdistfiles.tcl fetch_common.tcl portsandbox.tcl \ + portfetch_run.tcl include $(srcdir)/../../Mk/macports.subdir.mk @@ -32,12 +33,9 @@ distclean:: clean install:: all $(INSTALL) -d -o "${DSTUSR}" -g "${DSTGRP}" -m "${DSTMODE}" "${DESTDIR}${INSTALLDIR}" - $(SILENT)set -x; for file in ${SRCS}; do \ + $(SILENT)set -x; for file in ${SRCS} ${SRCS_AUTOCONF}; do \ $(INSTALL) -o "${DSTUSR}" -g "${DSTGRP}" -m 444 "$(srcdir)/$$file" "${DESTDIR}${INSTALLDIR}"; \ done - $(SILENT)set -x; for file in ${SRCS_AUTOCONF}; do \ - $(INSTALL) -o "${DSTUSR}" -g "${DSTGRP}" -m 444 "$$file" "${DESTDIR}${INSTALLDIR}"; \ - done $(INSTALL) -o "${DSTUSR}" -g "${DSTGRP}" -m 444 pkgIndex.tcl "${DESTDIR}${INSTALLDIR}" test:: diff --git a/src/port1.0/portfetch.tcl b/src/port1.0/portfetch.tcl index c425679f3..e4965a301 100644 --- a/src/port1.0/portfetch.tcl +++ b/src/port1.0/portfetch.tcl @@ -30,16 +30,15 @@ # package provide portfetch 1.0 -package require fetch_common 1.0 package require portextract 1.0 package require portutil 1.0 -package require Pextlib 1.0 set org.macports.fetch [target_new org.macports.fetch portfetch::fetch_main] target_init ${org.macports.fetch} portfetch::fetch_init target_provides ${org.macports.fetch} fetch target_requires ${org.macports.fetch} main target_prerun ${org.macports.fetch} portfetch::fetch_start +target_runpkg ${org.macports.fetch} portfetch_run namespace eval portfetch { variable fetch_urls {} @@ -102,7 +101,7 @@ default hg.dir {${workpath}} default hg.tag tip # Set distfiles -default distfiles {[list [portfetch::suffix [join $distname]]]} +default distfiles {[list [join $distname][join ${extract.suffix}]]} default dist_subdir {${name}} # user name & password @@ -165,599 +164,8 @@ proc portfetch::find_git_path {args} { } } -set_ui_prefix - - -# Given a distname, return the distname with extract.suffix appended -proc portfetch::suffix {distname} { - global extract.suffix - return ${distname}[join ${extract.suffix}] -} - -# Checks patch files and their tags to assemble url lists for later fetching -proc portfetch::checkpatchfiles {urls} { - global patchfiles all_dist_files patch_sites filespath - upvar $urls fetch_urls - - if {[info exists patchfiles]} { - foreach file $patchfiles { - if {![file exists "${filespath}/${file}"]} { - set distsite [getdisttag $file] - set file [getdistname $file] - lappend all_dist_files $file - if {$distsite ne ""} { - lappend fetch_urls $distsite $file - } elseif {[info exists patch_sites]} { - lappend fetch_urls patch_sites $file - } else { - lappend fetch_urls master_sites $file - } - } - } - } -} - -# Checks dist files and their tags to assemble url lists for later fetching -proc portfetch::checkdistfiles {urls} { - global distfiles all_dist_files filespath - upvar $urls fetch_urls - - if {[info exists distfiles]} { - foreach file $distfiles { - if {![file exists "${filespath}/${file}"]} { - set distsite [getdisttag $file] - set file [getdistname $file] - lappend all_dist_files $file - if {$distsite ne ""} { - lappend fetch_urls $distsite $file - } else { - lappend fetch_urls master_sites $file - } - } - } - } -} - -# returns full path to mirror list file -proc portfetch::get_full_mirror_sites_path {} { - global mirror_sites.listfile mirror_sites.listpath porturl - return [getportresourcepath $porturl [file join ${mirror_sites.listpath} ${mirror_sites.listfile}]] -} - -# Perform the full checksites/checkpatchfiles/checkdistfiles sequence. -# This method is used by distcheck target. -proc portfetch::checkfiles {urls} { - global global_mirror_site ports_fetch_no-mirrors license - upvar $urls fetch_urls - - set sites [list patch_sites [list] \ - master_sites [list]] - if {(![info exists ports_fetch_no-mirrors] || ${ports_fetch_no-mirrors} eq "no") \ - && [lsearch -exact -nocase $license "nomirror"] == -1} { - set sites [list patch_sites [list $global_mirror_site PATCH_SITE_LOCAL] \ - master_sites [list $global_mirror_site MASTER_SITE_LOCAL]] - } - - checksites $sites [get_full_mirror_sites_path] - checkpatchfiles fetch_urls - checkdistfiles fetch_urls -} - -# Perform a bzr fetch -proc portfetch::bzrfetch {args} { - global env patchfiles - - # Behind a proxy bzr will fail with the following error if proxies - # listed in macports.conf appear in the environment in their - # unmodified form: - # bzr: ERROR: Invalid url supplied to transport: - # "proxy.example.com:8080": No host component - # Set the "http_proxy" and "HTTPS_PROXY" environmental variables - # to valid URLs by prepending "http://" and appending "/". - foreach varname {http_proxy https_proxy HTTPS_PROXY} { - if {[info exists env($varname)] - && [string compare -length 7 {http://} $env($varname)] != 0 - } then { - set orig_${varname} $env($varname) - set env($varname) http://[set orig_${varname}]/ - } - } - - try { - if {[catch {command_exec bzr "" "2>&1"} result]} { - return -code error [msgcat::mc "Bazaar checkout failed"] - } - } finally { - foreach varname {http_proxy https_proxy HTTPS_PROXY} { - if {[info exists orig_${varname}]} { - set env($varname) [set orig_${varname}] - } - } - } - - if {[info exists patchfiles]} { - return [portfetch::fetchfiles] - } - - return 0 -} - -# Perform a CVS login and fetch, storing the CVS login -# information in a custom .cvspass file -proc portfetch::cvsfetch {args} { - global cvs.cmd cvs.args cvs.post_args \ - cvs.root cvs.date cvs.tag cvs.method cvs.password - patch_sites patchfiles filespath - - set cvs.args "${cvs.method} ${cvs.args}" - if {${cvs.method} eq "export" && ![string length ${cvs.tag}] && ![string length ${cvs.date}]} { - set cvs.tag "HEAD" - } - if {[string length ${cvs.tag}]} { - set cvs.args "${cvs.args} -r ${cvs.tag}" - } - - if {[string length ${cvs.date}]} { - set cvs.args "${cvs.args} -D ${cvs.date}" - } - - if {[regexp ^:pserver: ${cvs.root}]} { - set savecmd ${cvs.cmd} - set saveargs ${cvs.args} - set savepost_args ${cvs.post_args} - set cvs.cmd "echo ${cvs.password} | ${cvs.cmd}" - set cvs.args login - set cvs.post_args "" - if {[catch {command_exec -notty cvs "" "2>&1"} result]} { - return -code error [msgcat::mc "CVS login failed"] - } - set cvs.cmd ${savecmd} - set cvs.args ${saveargs} - set cvs.post_args ${savepost_args} - } else { - set env(CVS_RSH) ssh - } - - if {[catch {command_exec cvs "" "2>&1"} result]} { - return -code error [msgcat::mc "CVS check out failed"] - } - - if {[info exists patchfiles]} { - return [portfetch::fetchfiles] - } - return 0 -} - -# Given a URL to a Subversion repository, if the URL is http:// or -# https:// and MacPorts has been configured with a proxy for that URL -# type, then return command line options that should be passed to the -# svn command line client to enable use of that proxy. There are no -# proxies for Subversion's native protocol, identified by svn:// URLs. -proc portfetch::svn_proxy_args {url} { - global env - - if { [string compare -length 7 {http://} ${url}] == 0 - && [info exists env(http_proxy)]} { - set proxy_str $env(http_proxy) - } elseif { [string compare -length 8 {https://} ${url}] == 0 - && ([info exists env(HTTPS_PROXY)] || [info exists env(https_proxy)])} { - set proxy_str [expr {[info exists env(https_proxy)] ? $env(https_proxy) : $env(HTTPS_PROXY)}] - } else { - return "" - } - regexp {(.*://)?([[:alnum:].-]+)(:(\d+))?} $proxy_str - - proxy_host - proxy_port - set ret "--config-option servers:global:http-proxy-host=${proxy_host}" - if {$proxy_port ne ""} { - append ret " --config-option servers:global:http-proxy-port=${proxy_port}" - } - return $ret -} - -# Perform an svn fetch -proc portfetch::svnfetch {args} { - global svn.args svn.method svn.revision svn.url patchfiles \ - fetch.user fetch.password - - if {[regexp {\s} ${svn.url}]} { - return -code error [msgcat::mc "Subversion URL cannot contain whitespace"] - } - - if {[string length ${svn.revision}]} { - append svn.url "@${svn.revision}" - } - - if {[option fetch.ignore_sslcert]} { - svn.pre_args-append --trust-server-cert - } - if {${fetch.user} ne {}} { - svn.pre_args-append --username ${fetch.user} - } - if {${fetch.password} ne {}} { - svn.pre_args-append --password ${fetch.password} - } - - set proxy_args [svn_proxy_args ${svn.url}] - - set svn.args "${svn.method} ${svn.args} ${proxy_args} ${svn.url}" - - if {[catch {command_exec svn "" "2>&1"} result]} { - return -code error [msgcat::mc "Subversion check out failed"] - } - - if {[info exists patchfiles]} { - return [portfetch::fetchfiles] - } - - return 0 -} - -# Perform a git fetch -proc portfetch::gitfetch {args} { - global worksrcpath patchfiles \ - git.url git.branch git.cmd - - set options "--progress" - if {${git.branch} eq ""} { - # if we're just using HEAD, we can make a shallow repo - append options " --depth=1" - } - set cmdstring "${git.cmd} clone $options ${git.url} [shellescape ${worksrcpath}] 2>&1" - ui_debug "Executing: $cmdstring" - if {[catch {system $cmdstring} result]} { - return -code error [msgcat::mc "Git clone failed"] - } - - if {${git.branch} ne ""} { - set env "GIT_DIR=[shellescape ${worksrcpath}/.git] GIT_WORK_TREE=[shellescape ${worksrcpath}]" - set cmdstring "$env ${git.cmd} checkout -q ${git.branch} 2>&1" - ui_debug "Executing $cmdstring" - if {[catch {system $cmdstring} result]} { - return -code error [msgcat::mc "Git checkout failed"] - } - } - - if {[info exists patchfiles]} { - return [portfetch::fetchfiles] - } - - return 0 -} - -# Perform a mercurial fetch. -proc portfetch::hgfetch {args} { - global worksrcpath patchfiles hg.url hg.tag hg.cmd \ - fetch.ignore_sslcert - - set insecureflag "" - if {${fetch.ignore_sslcert}} { - set insecureflag " --insecure" - } - - set cmdstring "${hg.cmd} clone${insecureflag} --rev \"${hg.tag}\" ${hg.url} [shellescape ${worksrcpath}] 2>&1" - ui_debug "Executing: $cmdstring" - if {[catch {system $cmdstring} result]} { - return -code error [msgcat::mc "Mercurial clone failed"] - } - - if {[info exists patchfiles]} { - return [portfetch::fetchfiles] - } - - return 0 -} - -# Perform a standard fetch, assembling fetch urls from -# the listed url variable and associated distfile -proc portfetch::fetchfiles {{async no} args} { - global distpath UI_PREFIX \ - fetch.user fetch.password fetch.use_epsv fetch.ignore_sslcert fetch.remote_time \ - fetch.user_agent portverbose - variable fetch_urls - variable urlmap - variable async_jobs - variable async_logid - - if {$async} { - if {[info exists async_jobs]} { - # Async fetch already started - return 0 - } - set async_jobs [list] - } elseif {[info exists async_jobs]} { - # Fetch was started asynchronously, wait for jobs to finish - set async_jobs_copy $async_jobs - # Ensure we don't try to get results for jobs twice - unset async_jobs - set any_failed 0 - foreach {distfile jobid} $async_jobs_copy { - set cancelled 0 - if {![curlwrap_async_is_complete $jobid]} { - if {!$any_failed} { - # Display progress for this fetch while waiting for it to finish - curlwrap_async_show_progress $jobid - # Loop with a reasonable timeout so we don't wait too long - # to handle events like signals. - while {![curlwrap_async_is_complete $jobid 500]} {} - } else { - # If something failed, stop other incomplete jobs so we fail fast - curlwrap_async_cancel $jobid - set cancelled 1 - } - } - if {!$cancelled} { - lassign [curlwrap_async_result $jobid] status result - if {$status != 0} { - # Some ports have a lot of distfiles, so don't print an - # error for all of them outside of debug mode. - if {!$any_failed} { - ui_error "Failed to fetch ${distfile}: $result" - } else { - ui_debug "Failed to fetch ${distfile}: $result" - } - set any_failed 1 - file delete -force ${distpath}/${distfile}.TMP - } elseif {![file exists ${distpath}/${distfile}]} { - file rename -force ${distpath}/${distfile}.TMP ${distpath}/${distfile} - } - } else { - file delete -force ${distpath}/${distfile}.TMP - } - } - if {$any_failed} { - error "Failed to fetch distfiles" - } - return 0 - } - - set fetch_options [list] - set credentials {} - if {[string length ${fetch.user}] || [string length ${fetch.password}]} { - set credentials ${fetch.user}:${fetch.password} - } - if {${fetch.use_epsv} ne "yes"} { - lappend fetch_options "--disable-epsv" - } - if {${fetch.ignore_sslcert} ne "no"} { - lappend fetch_options "--ignore-ssl-cert" - } - if {${fetch.remote_time} ne "no"} { - lappend fetch_options "--remote-time" - } - if {${fetch.user_agent} ne ""} { - lappend fetch_options "--user-agent" - lappend fetch_options "${fetch.user_agent}" - } - if {!$async} { - if {$portverbose eq "yes"} { - lappend fetch_options "--progress" - lappend fetch_options "builtin" - } else { - lappend fetch_options "--progress" - lappend fetch_options "ui_progress_download" - } - } - set sorted no - - foreach {url_var distfile} $fetch_urls { - if {![file isfile ${distpath}/${distfile}]} { - if {!$async} { - ui_info "$UI_PREFIX [format [msgcat::mc "%s does not exist in %s"] $distfile $distpath]" - } - if {![file writable $distpath]} { - return -code error [format [msgcat::mc "%s must be writable"] $distpath] - } - if {!$sorted} { - sortsites fetch_urls master_sites - set sorted yes - } - if {![info exists urlmap($url_var)]} { - ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var] - set urlmap($url_var) $urlmap(master_sites) - } - if {$async} { - # Skip if something else is already fetching this file - if {[curlwrap_async_file_is_in_progress ${distpath}/${distfile}]} { - continue - } - file delete -force ${distpath}/${distfile}.TMP - touch ${distpath}/${distfile}.TMP - chownAsRoot ${distpath}/${distfile}.TMP - lappend async_jobs $distfile \ - [curlwrap_async fetch_file $credentials $fetch_options $urlmap($url_var) \ - [lmap site $urlmap($url_var) {portfetch::assemble_url $site $distfile}] \ - ${distpath}/${distfile} $async_logid] - } else { - unset -nocomplain fetched - set lastError "" - foreach site $urlmap($url_var) { - ui_notice "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]" - set file_url [portfetch::assemble_url $site $distfile] - macports_try -pass_signal { - curlwrap fetch $site $credentials {*}$fetch_options $file_url ${distpath}/${distfile}.TMP - file rename -force "${distpath}/${distfile}.TMP" "${distpath}/${distfile}" - set fetched 1 - break - } on error {eMessage} { - ui_debug [msgcat::mc "Fetching distfile failed: %s" $eMessage] - set lastError $eMessage - } finally { - file delete -force "${distpath}/${distfile}.TMP" - } - } - if {![info exists fetched]} { - if {$lastError ne ""} { - error $lastError - } else { - error [msgcat::mc "fetch failed"] - } - } - } - } - } - return 0 -} - -# Utility function to delete fetched files. -proc portfetch::fetch_deletefiles {args} { - global distpath - variable fetch_urls - foreach {url_var distfile} $fetch_urls { - if {[file isfile $distpath/$distfile]} { - file delete -force "${distpath}/${distfile}" - } - } -} - -# Utility function to add files to a list of fetched files. -proc portfetch::fetch_addfilestomap {filemapname} { - global distpath $filemapname - variable fetch_urls - foreach {url_var distfile} $fetch_urls { - if {[file isfile $distpath/$distfile]} { - filemap set $filemapname $distpath/$distfile 1 - } - } -} - -# Check if all distfiles are already present. -proc portfetch::files_present {} { - global distpath - variable fetch_urls - foreach {url_var distfile} $fetch_urls { - if {![file isfile ${distpath}/${distfile}]} { - return 0 - } - } - return 1 -} - -# Start asynchronous fetch of distfiles proc portfetch::fetch_async_start {logid} { - global all_dist_files fetch.type - if {${fetch.type} ne "standard"} { - # Async only supported for file fetches - return 0 - } - fetch_init - if {![info exists all_dist_files]} { - # No files to fetch - return 0 - } - if {[files_present]} { - # Already fetched - return 0 - } - _fetch_start - variable async_logid $logid - fetchfiles yes -} - -proc portfetch::_async_cleanup {} { - variable async_jobs - if {[info exists async_jobs]} { - global distpath - foreach {distfile jobid} $async_jobs { - curlwrap_async_cancel $jobid - file delete ${distpath}/${distfile}.TMP - } - unset async_jobs - } -} - -proc portfetch::start_pings {} { - variable fetch_urls - variable urlmap - # ping hosts that are not in the cache yet - foreach {url_var distfile} $fetch_urls { - if {[info exists urlmap($url_var)]} { - async_ping_start $urlmap($url_var) - } - } - # wait until we have a result for at least the main mirror - global global_mirror_site - if {[info exists mirror_sites::sites($global_mirror_site)]} { - set primary_mirror [lindex $mirror_sites::sites($global_mirror_site) 0] - if {$primary_mirror ne {}} { - wait_for_pingtime $primary_mirror - } - } -} - -# Initialize fetch target and call checkfiles. -proc portfetch::fetch_init {args} { - variable fetch_urls - - if {${fetch_urls} eq ""} { - portfetch::checkfiles fetch_urls - } -} - -proc portfetch::_fetch_start {} { - global UI_PREFIX distpath all_dist_files - - if {[info exists all_dist_files]} { - start_pings - } - - # create and chown $distpath - if {![file isdirectory $distpath]} { - if {[catch {file mkdir $distpath} result]} { - elevateToRoot "fetch" - if {[catch {file mkdir $distpath} result]} { - return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result] - } - chownAsRoot $distpath - dropPrivileges - } - } - if {![file owned $distpath]} { - if {[catch {chownAsRoot $distpath} result]} { - if {[file writable $distpath]} { - ui_warn "$UI_PREFIX [format [msgcat::mc "Couldn't change ownership of distribution files path to macports user: %s"] $result]" - } else { - return -code error [format [msgcat::mc "Distribution files path %s not writable and could not be chowned: %s"] $distpath $result] - } - } - } - - portfetch::check_dns -} - -proc portfetch::fetch_start {args} { - global subport UI_PREFIX portarchivefetch::attempted - - if {[tbool attempted]} { - ui_notice "$UI_PREFIX [format [msgcat::mc "Archive not available for %s, building locally"] $subport]" - } - - ui_notice "$UI_PREFIX [format [msgcat::mc "Fetching distfiles for %s"] $subport]" - if {[files_present]} { - # Already fetched - return 0 - } - _fetch_start -} - -# Main fetch routine -# If all_dist_files is not populated and $fetch.type == standard, then -# there are no files to download. Otherwise, either do a cvs checkout -# or call the standard fetchfiles procedure -proc portfetch::fetch_main {args} { - global all_dist_files fetch.type - - # Check for files, download if necessary - if {![info exists all_dist_files] && "${fetch.type}" eq "standard"} { - return 0 - } - - # Fetch the files - switch -- "${fetch.type}" { - bzr { return [bzrfetch] } - cvs { return [cvsfetch] } - svn { return [svnfetch] } - git { return [gitfetch] } - hg { return [hgfetch] } - standard - - default { return [portfetch::fetchfiles] } - } + global org.macports.fetch + portutil::target_load ${org.macports.fetch} + _fetch_async_start $logid } diff --git a/src/port1.0/portfetch_run.tcl b/src/port1.0/portfetch_run.tcl new file mode 100644 index 000000000..db39ce362 --- /dev/null +++ b/src/port1.0/portfetch_run.tcl @@ -0,0 +1,577 @@ +# -*- coding: utf-8; mode: tcl; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*- vim:fenc=utf-8:ft=tcl:et:sw=4:ts=4:sts=4 + +# Code needed to run the fetch target + +package provide portfetch_run 1.0 +package require fetch_common 1.0 +package require Pextlib 1.0 + +namespace eval portfetch { + +# Checks patch files and their tags to assemble url lists for later fetching +proc checkpatchfiles {urls} { + global patchfiles all_dist_files patch_sites filespath + upvar $urls fetch_urls + + if {[info exists patchfiles]} { + foreach file $patchfiles { + if {![file exists ${filespath}/${file}]} { + set distsite [getdisttag $file] + set file [getdistname $file] + lappend all_dist_files $file + if {$distsite ne {}} { + lappend fetch_urls $distsite $file + } elseif {[info exists patch_sites]} { + lappend fetch_urls patch_sites $file + } else { + lappend fetch_urls master_sites $file + } + } + } + } +} + +# Checks dist files and their tags to assemble url lists for later fetching +proc checkdistfiles {urls} { + global distfiles all_dist_files filespath + upvar $urls fetch_urls + + if {[info exists distfiles]} { + foreach file $distfiles { + if {![file exists ${filespath}/${file}]} { + set distsite [getdisttag $file] + set file [getdistname $file] + lappend all_dist_files $file + if {$distsite ne {}} { + lappend fetch_urls $distsite $file + } else { + lappend fetch_urls master_sites $file + } + } + } + } +} + +# returns full path to mirror list file +proc get_full_mirror_sites_path {} { + global mirror_sites.listfile mirror_sites.listpath porturl + return [getportresourcepath $porturl [file join ${mirror_sites.listpath} ${mirror_sites.listfile}]] +} + +# Perform the full checksites/checkpatchfiles/checkdistfiles sequence. +# This method is used by distcheck target. +proc checkfiles {urls} { + global global_mirror_site ports_fetch_no-mirrors license + upvar $urls fetch_urls + + set sites [list patch_sites [list] \ + master_sites [list]] + if {(![info exists ports_fetch_no-mirrors] || ${ports_fetch_no-mirrors} eq "no") \ + && [lsearch -exact -nocase $license "nomirror"] == -1} { + set sites [list patch_sites [list $global_mirror_site PATCH_SITE_LOCAL] \ + master_sites [list $global_mirror_site MASTER_SITE_LOCAL]] + } + + checksites $sites [get_full_mirror_sites_path] + checkpatchfiles fetch_urls + checkdistfiles fetch_urls +} + +# Perform a bzr fetch +proc bzrfetch {args} { + global env patchfiles + + # Behind a proxy bzr will fail with the following error if proxies + # listed in macports.conf appear in the environment in their + # unmodified form: + # bzr: ERROR: Invalid url supplied to transport: + # "proxy.example.com:8080": No host component + # Set the "http_proxy" and "HTTPS_PROXY" environmental variables + # to valid URLs by prepending "http://" and appending "/". + foreach varname {http_proxy https_proxy HTTPS_PROXY} { + if {[info exists env($varname)] + && [string compare -length 7 {http://} $env($varname)] != 0 + } then { + set orig_${varname} $env($varname) + set env($varname) http://[set orig_${varname}]/ + } + } + + try { + if {[catch {command_exec bzr "" "2>&1"} result]} { + return -code error [msgcat::mc "Bazaar checkout failed"] + } + } finally { + foreach varname {http_proxy https_proxy HTTPS_PROXY} { + if {[info exists orig_${varname}]} { + set env($varname) [set orig_${varname}] + } + } + } + + if {[info exists patchfiles]} { + return [fetchfiles] + } + + return 0 +} + +# Perform a CVS login and fetch, storing the CVS login +# information in a custom .cvspass file +proc cvsfetch {args} { + global cvs.cmd cvs.args cvs.post_args \ + cvs.root cvs.date cvs.tag cvs.method cvs.password + patch_sites patchfiles filespath + + set cvs.args "${cvs.method} ${cvs.args}" + if {${cvs.method} eq "export" && ![string length ${cvs.tag}] && ![string length ${cvs.date}]} { + set cvs.tag HEAD + } + if {[string length ${cvs.tag}]} { + set cvs.args "${cvs.args} -r ${cvs.tag}" + } + + if {[string length ${cvs.date}]} { + set cvs.args "${cvs.args} -D ${cvs.date}" + } + + if {[regexp ^:pserver: ${cvs.root}]} { + set savecmd ${cvs.cmd} + set saveargs ${cvs.args} + set savepost_args ${cvs.post_args} + set cvs.cmd "echo ${cvs.password} | ${cvs.cmd}" + set cvs.args login + set cvs.post_args "" + if {[catch {command_exec -notty cvs "" "2>&1"} result]} { + return -code error [msgcat::mc "CVS login failed"] + } + set cvs.cmd ${savecmd} + set cvs.args ${saveargs} + set cvs.post_args ${savepost_args} + } else { + set env(CVS_RSH) ssh + } + + if {[catch {command_exec cvs "" "2>&1"} result]} { + return -code error [msgcat::mc "CVS check out failed"] + } + + if {[info exists patchfiles]} { + return [fetchfiles] + } + return 0 +} + +# Given a URL to a Subversion repository, if the URL is http:// or +# https:// and MacPorts has been configured with a proxy for that URL +# type, then return command line options that should be passed to the +# svn command line client to enable use of that proxy. There are no +# proxies for Subversion's native protocol, identified by svn:// URLs. +proc svn_proxy_args {url} { + global env + + if { [string compare -length 7 {http://} ${url}] == 0 + && [info exists env(http_proxy)]} { + set proxy_str $env(http_proxy) + } elseif { [string compare -length 8 {https://} ${url}] == 0 + && ([info exists env(HTTPS_PROXY)] || [info exists env(https_proxy)])} { + set proxy_str [expr {[info exists env(https_proxy)] ? $env(https_proxy) : $env(HTTPS_PROXY)}] + } else { + return "" + } + regexp {(.*://)?([[:alnum:].-]+)(:(\d+))?} $proxy_str - - proxy_host - proxy_port + set ret "--config-option servers:global:http-proxy-host=${proxy_host}" + if {$proxy_port ne ""} { + append ret " --config-option servers:global:http-proxy-port=${proxy_port}" + } + return $ret +} + +# Perform an svn fetch +proc svnfetch {args} { + global svn.args svn.method svn.revision svn.url patchfiles \ + fetch.user fetch.password + + if {[regexp {\s} ${svn.url}]} { + return -code error [msgcat::mc "Subversion URL cannot contain whitespace"] + } + + if {[string length ${svn.revision}]} { + append svn.url @${svn.revision} + } + + if {[option fetch.ignore_sslcert]} { + svn.pre_args-append --trust-server-cert + } + if {${fetch.user} ne {}} { + svn.pre_args-append --username ${fetch.user} + } + if {${fetch.password} ne {}} { + svn.pre_args-append --password ${fetch.password} + } + + set proxy_args [svn_proxy_args ${svn.url}] + + set svn.args "${svn.method} ${svn.args} ${proxy_args} ${svn.url}" + + if {[catch {command_exec svn "" "2>&1"} result]} { + return -code error [msgcat::mc "Subversion check out failed"] + } + + if {[info exists patchfiles]} { + return [fetchfiles] + } + + return 0 +} + +# Perform a git fetch +proc gitfetch {args} { + global worksrcpath patchfiles \ + git.url git.branch git.cmd + + set options "--progress" + if {${git.branch} eq ""} { + # if we're just using HEAD, we can make a shallow repo + append options " --depth=1" + } + set cmdstring "${git.cmd} clone $options ${git.url} [shellescape ${worksrcpath}] 2>&1" + ui_debug "Executing: $cmdstring" + if {[catch {system $cmdstring} result]} { + return -code error [msgcat::mc "Git clone failed"] + } + + if {${git.branch} ne ""} { + set env "GIT_DIR=[shellescape ${worksrcpath}/.git] GIT_WORK_TREE=[shellescape ${worksrcpath}]" + set cmdstring "$env ${git.cmd} checkout -q ${git.branch} 2>&1" + ui_debug "Executing $cmdstring" + if {[catch {system $cmdstring} result]} { + return -code error [msgcat::mc "Git checkout failed"] + } + } + + if {[info exists patchfiles]} { + return [fetchfiles] + } + + return 0 +} + +# Perform a mercurial fetch. +proc hgfetch {args} { + global worksrcpath patchfiles hg.url hg.tag hg.cmd \ + fetch.ignore_sslcert + + set insecureflag "" + if {${fetch.ignore_sslcert}} { + set insecureflag " --insecure" + } + + set cmdstring "${hg.cmd} clone${insecureflag} --rev \"${hg.tag}\" ${hg.url} [shellescape ${worksrcpath}] 2>&1" + ui_debug "Executing: $cmdstring" + if {[catch {system $cmdstring} result]} { + return -code error [msgcat::mc "Mercurial clone failed"] + } + + if {[info exists patchfiles]} { + return [fetchfiles] + } + + return 0 +} + +# Perform a standard fetch, assembling fetch urls from +# the listed url variable and associated distfile +proc fetchfiles {{async no} args} { + global distpath UI_PREFIX \ + fetch.user fetch.password fetch.use_epsv fetch.ignore_sslcert fetch.remote_time \ + fetch.user_agent portverbose + variable fetch_urls + variable urlmap + variable async_jobs + variable async_logid + + if {$async} { + if {[info exists async_jobs]} { + # Async fetch already started + return 0 + } + set async_jobs [list] + } elseif {[info exists async_jobs]} { + # Fetch was started asynchronously, wait for jobs to finish + set async_jobs_copy $async_jobs + # Ensure we don't try to get results for jobs twice + unset async_jobs + set any_failed 0 + foreach {distfile jobid} $async_jobs_copy { + set cancelled 0 + if {![curlwrap_async_is_complete $jobid]} { + if {!$any_failed} { + # Display progress for this fetch while waiting for it to finish + curlwrap_async_show_progress $jobid + # Loop with a reasonable timeout so we don't wait too long + # to handle events like signals. + while {![curlwrap_async_is_complete $jobid 500]} {} + } else { + # If something failed, stop other incomplete jobs so we fail fast + curlwrap_async_cancel $jobid + set cancelled 1 + } + } + if {!$cancelled} { + lassign [curlwrap_async_result $jobid] status result + if {$status != 0} { + # Some ports have a lot of distfiles, so don't print an + # error for all of them outside of debug mode. + if {!$any_failed} { + ui_error "Failed to fetch ${distfile}: $result" + } else { + ui_debug "Failed to fetch ${distfile}: $result" + } + set any_failed 1 + file delete -force ${distpath}/${distfile}.TMP + } elseif {![file exists ${distpath}/${distfile}]} { + file rename -force ${distpath}/${distfile}.TMP ${distpath}/${distfile} + } + } else { + file delete -force ${distpath}/${distfile}.TMP + } + } + if {$any_failed} { + error "Failed to fetch distfiles" + } + return 0 + } + + set fetch_options [list] + set credentials {} + if {[string length ${fetch.user}] || [string length ${fetch.password}]} { + set credentials ${fetch.user}:${fetch.password} + } + if {${fetch.use_epsv} ne "yes"} { + lappend fetch_options "--disable-epsv" + } + if {${fetch.ignore_sslcert} ne "no"} { + lappend fetch_options "--ignore-ssl-cert" + } + if {${fetch.remote_time} ne "no"} { + lappend fetch_options "--remote-time" + } + if {${fetch.user_agent} ne ""} { + lappend fetch_options "--user-agent" + lappend fetch_options "${fetch.user_agent}" + } + if {!$async} { + if {$portverbose eq "yes"} { + lappend fetch_options "--progress" + lappend fetch_options "builtin" + } else { + lappend fetch_options "--progress" + lappend fetch_options "ui_progress_download" + } + } + set sorted no + + foreach {url_var distfile} $fetch_urls { + if {![file isfile ${distpath}/${distfile}]} { + if {!$async} { + ui_info "$UI_PREFIX [format [msgcat::mc "%s does not exist in %s"] $distfile $distpath]" + } + if {![file writable $distpath]} { + return -code error [format [msgcat::mc "%s must be writable"] $distpath] + } + if {!$sorted} { + sortsites fetch_urls master_sites + set sorted yes + } + if {![info exists urlmap($url_var)]} { + ui_error [format [msgcat::mc "No defined site for tag: %s, using master_sites"] $url_var] + set urlmap($url_var) $urlmap(master_sites) + } + if {$async} { + # Skip if something else is already fetching this file + if {[curlwrap_async_file_is_in_progress ${distpath}/${distfile}]} { + continue + } + file delete -force ${distpath}/${distfile}.TMP + touch ${distpath}/${distfile}.TMP + chownAsRoot ${distpath}/${distfile}.TMP + lappend async_jobs $distfile \ + [curlwrap_async fetch_file $credentials $fetch_options $urlmap($url_var) \ + [lmap site $urlmap($url_var) {assemble_url $site $distfile}] \ + ${distpath}/${distfile} $async_logid] + } else { + unset -nocomplain fetched + set lastError "" + foreach site $urlmap($url_var) { + ui_notice "$UI_PREFIX [format [msgcat::mc "Attempting to fetch %s from %s"] $distfile $site]" + set file_url [assemble_url $site $distfile] + macports_try -pass_signal { + curlwrap fetch $site $credentials {*}$fetch_options $file_url ${distpath}/${distfile}.TMP + file rename -force "${distpath}/${distfile}.TMP" "${distpath}/${distfile}" + set fetched 1 + break + } on error {eMessage} { + ui_debug [msgcat::mc "Fetching distfile failed: %s" $eMessage] + set lastError $eMessage + } finally { + file delete -force "${distpath}/${distfile}.TMP" + } + } + if {![info exists fetched]} { + if {$lastError ne ""} { + error $lastError + } else { + error [msgcat::mc "fetch failed"] + } + } + } + } + } + return 0 +} + +# Check if all distfiles are already present. +proc files_present {} { + global distpath + variable fetch_urls + foreach {url_var distfile} $fetch_urls { + if {![file isfile ${distpath}/${distfile}]} { + return 0 + } + } + return 1 +} + +# Start asynchronous fetch of distfiles +proc _fetch_async_start {logid} { + global all_dist_files fetch.type + if {${fetch.type} ne "standard"} { + # Async only supported for file fetches + return 0 + } + fetch_init + if {![info exists all_dist_files]} { + # No files to fetch + return 0 + } + if {[files_present]} { + # Already fetched + return 0 + } + _fetch_start + variable async_logid $logid + fetchfiles yes +} + +proc _async_cleanup {} { + variable async_jobs + if {[info exists async_jobs]} { + global distpath + foreach {distfile jobid} $async_jobs { + curlwrap_async_cancel $jobid + file delete ${distpath}/${distfile}.TMP + } + unset async_jobs + } +} + +proc start_pings {} { + variable fetch_urls + variable urlmap + # ping hosts that are not in the cache yet + foreach {url_var distfile} $fetch_urls { + if {[info exists urlmap($url_var)]} { + async_ping_start $urlmap($url_var) + } + } + # wait until we have a result for at least the main mirror + global global_mirror_site + if {[info exists mirror_sites::sites($global_mirror_site)]} { + set primary_mirror [lindex $mirror_sites::sites($global_mirror_site) 0] + if {$primary_mirror ne {}} { + wait_for_pingtime $primary_mirror + } + } +} + +# Initialize fetch target and call checkfiles. +proc fetch_init {args} { + variable fetch_urls + + if {${fetch_urls} eq ""} { + checkfiles fetch_urls + } +} + +proc _fetch_start {} { + global UI_PREFIX distpath all_dist_files + + if {[info exists all_dist_files]} { + start_pings + } + + # create and chown $distpath + if {![file isdirectory $distpath]} { + if {[catch {file mkdir $distpath} result]} { + elevateToRoot "fetch" + if {[catch {file mkdir $distpath} result]} { + return -code error [format [msgcat::mc "Unable to create distribution files path: %s"] $result] + } + chownAsRoot $distpath + dropPrivileges + } + } + if {![file owned $distpath]} { + if {[catch {chownAsRoot $distpath} result]} { + if {[file writable $distpath]} { + ui_warn "$UI_PREFIX [format [msgcat::mc "Couldn't change ownership of distribution files path to macports user: %s"] $result]" + } else { + return -code error [format [msgcat::mc "Distribution files path %s not writable and could not be chowned: %s"] $distpath $result] + } + } + } + + check_dns +} + +proc fetch_start {args} { + global subport UI_PREFIX portarchivefetch::attempted + + if {[tbool attempted]} { + ui_notice "$UI_PREFIX [format [msgcat::mc "Archive not available for %s, building locally"] $subport]" + } + + ui_notice "$UI_PREFIX [format [msgcat::mc "Fetching distfiles for %s"] $subport]" + if {[files_present]} { + # Already fetched + return 0 + } + _fetch_start +} + +# Main fetch routine +# If all_dist_files is not populated and $fetch.type == standard, then +# there are no files to download. Otherwise, either do a cvs checkout +# or call the standard fetchfiles procedure +proc fetch_main {args} { + global all_dist_files fetch.type + + # Check for files, download if necessary + if {![info exists all_dist_files] && ${fetch.type} eq "standard"} { + return 0 + } + + # Fetch the files + switch -- ${fetch.type} { + bzr { return [bzrfetch] } + cvs { return [cvsfetch] } + svn { return [svnfetch] } + git { return [gitfetch] } + hg { return [hgfetch] } + standard - + default { return [fetchfiles] } + } +} + +} diff --git a/src/port1.0/portmirror.tcl b/src/port1.0/portmirror.tcl index cd58c3152..862a7de02 100644 --- a/src/port1.0/portmirror.tcl +++ b/src/port1.0/portmirror.tcl @@ -50,6 +50,26 @@ namespace eval portmirror { # if the checksum isn't correct. # It also records the path in a database. +# Utility function to delete fetched files. +proc portmirror::fetch_deletefiles {args} { + global distpath portfetch::fetch_urls + foreach {url_var distfile} $fetch_urls { + if {[file isfile $distpath/$distfile]} { + file delete ${distpath}/${distfile} + } + } +} + +# Utility function to add files to a list of fetched files. +proc portmirror::fetch_addfilestomap {filemapname} { + global distpath $filemapname portfetch::fetch_urls + foreach {url_var distfile} $fetch_urls { + if {[file isfile $distpath/$distfile]} { + filemap set $filemapname $distpath/$distfile 1 + } + } +} + proc portmirror::mirror_main {args} { global fetch.type mirror_filemap portdbpath subport license @@ -73,7 +93,7 @@ proc portmirror::mirror_main {args} { # checksum the files. if {[catch {portchecksum::checksum_main $args} result]} { # delete the files. - portfetch::fetch_deletefiles $args + fetch_deletefiles $args exec_with_available_privileges { filemap close mirror_filemap } @@ -81,7 +101,7 @@ proc portmirror::mirror_main {args} { } # add the list of files. - portfetch::fetch_addfilestomap mirror_filemap + fetch_addfilestomap mirror_filemap } # close the filemap. diff --git a/src/port1.0/portutil.tcl b/src/port1.0/portutil.tcl index 6e0590d72..38f39fa79 100644 --- a/src/port1.0/portutil.tcl +++ b/src/port1.0/portutil.tcl @@ -1358,6 +1358,14 @@ proc lipo {} { ########### Internal Dependency Manipulation Procedures ########### set ports_dry_last_skipped "" +# Load any extra code needed to run the given target +proc portutil::target_load {ditem} { + set runpkg [ditem_key $ditem runpkg] + if {$runpkg ne {}} { + package require $runpkg + } +} + proc target_run {ditem} { global target_state_fd workpath portpath ports_trace PortInfo ports_dryrun \ ports_dry_last_skipped worksrcpath subport env portdbpath \ @@ -1377,6 +1385,7 @@ proc target_run {ditem} { } if {$procedure ne ""} { + portutil::target_load $ditem set targetname [ditem_key $ditem name] set target [ditem_key $ditem provides] portsandbox::set_profile $target @@ -2341,6 +2350,10 @@ proc target_init {ditem args} { ditem_append $ditem init {*}$args } +proc target_runpkg {ditem pkg} { + ditem_key $ditem runpkg $pkg +} + ##### variant class ##### # constructor for variant objects @@ -3596,6 +3609,7 @@ proc portutil::_eval_archive_available {{async no}} { } lappend sites_entries $primary_mirror # Build list of URLs to check for the archive and its signature. + package require fetch_common set sites [list] set urls [list] foreach sites_entry $sites_entries {