branch/multisys/R/getrpkg.R

   1 setup <- function() {
   2     # set up the working directory
   3     tmp <- tempfile('cran2deb')
   4     dir.create(tmp)
   5     return (tmp)
   6 }
   7
   8 cleanup <- function(dir) {
   9     # remove the working directory
  10     unlink(dir,recursive=T)
  11     invisible()
  12 }
  13
  14 download_pkg <- function(dir, pkgname) {
  15     # download pkgname into dir, and construct some metadata
  16
  17     # record some basic information
  18     pkg <- pairlist()
  19     pkg$date_stamp = format(Sys.time(),'%a, %d %b %Y %H:%M:%S %z')
  20     pkg$name = pkgname
  21     pkg$repoURL = available[pkgname,'Repository']
  22     pkg$repo = repourl_as_debian(pkg$repoURL)
  23     if (!length(grep('^[A-Za-z0-9][A-Za-z0-9+.-]+$',pkg$name))) {
  24         fail('Cannot convert package name into a Debian name',pkg$name)
  25     }
  26     pkg$srcname = pkgname_as_debian(pkg$name,binary=F)
  27     pkg$debname = pkgname_as_debian(pkg$name,repo=pkg$repo)
  28     pkg$version <- available[pkgname,'Version']
  29
  30     # see if we have already built this release and uploaded it.
  31     debfn <- file.path(pbuilder_results, paste(pkg$srcname, '_', pkg$version, '.orig.tar.gz', sep=''))
  32     pkg$need_repack = FALSE
  33     if (file.exists(debfn)) {
  34         # if so, use the existing archive. this is good for three reasons:
  35         # 1. it saves downloading the archive again
  36         # 2. the repacking performed below changes the MD5 sum of the archive
  37         #    which upsets some Debian archive software.
  38         # 3. why repack more than once?
  39         pkg$archive <- file.path(dir, basename(debfn))
  40         file.copy(debfn,pkg$archive)
  41         pkg$path = file.path(dir, paste(pkg$srcname ,pkg$version ,sep='-'))
  42     } else {
  43         # see if we have a local mirror in /srv/R
  44         use_local = FALSE
  45         if (pkg$repo == 'cran') {
  46             localfn = file.path('/srv/R/Repositories/CRAN/src/contrib',paste(pkg$name,'_',pkg$version,'.tar.gz',sep=''))
  47             use_local = file.exists(localfn)
  48         } else if (pkg$repo == 'bioc') {
  49             localfn = file.path('/srv/R/Repositories/Bioconductor/release/bioc/src/contrib',paste(pkg$name,'_',pkg$version,'.tar.gz',sep=''))
  50             use_local = file.exists(localfn)
  51         }
  52
  53         fn <- paste(pkgname, '_', pkg$version, '.tar.gz', sep='')
  54         archive <- file.path(dir, fn)
  55
  56         if (use_local) {
  57             file.copy(localfn, archive)
  58         } else {
  59             # use this instead of download.packages as it is more resilient to
  60             # dodgy network connections (hello BT 'OpenWorld', bad ISP)
  61             url <- paste(available[pkgname,'Repository'], fn, sep='/')
  62             # don't log the output -- we don't care!
  63             ret <- system(paste('curl','-o',shQuote(archive),'-m 720 --retry 5',shQuote(url)))
  64             if (ret != 0) {
  65                 fail('failed to download',url)
  66             }
  67             # end of download.packages replacement
  68         }
  69
  70         if (length(grep('\\.\\.',archive)) || normalizePath(archive) != archive) {
  71             fail('funny looking path',archive)
  72         }
  73         pkg$path = sub("_\\.(zip|tar\\.gz)", ""
  74                       ,gsub(.standard_regexps()$valid_package_version, ""
  75                       ,archive))
  76         pkg$archive = archive
  77         # this is not a Debian conformant archive
  78         pkg$need_repack = TRUE
  79     }
  80     return(pkg)
  81 }
  82
  83 repack_pkg <- function(pkg) {
  84     # re-pack into a Debian-named archive with a Debian-named directory.
  85     debpath = file.path(dirname(pkg$archive)
  86                    ,paste(pkg$srcname
  87                          ,pkg$version
  88                          ,sep='-'))
  89     file.rename(pkg$path, debpath)
  90     pkg$path = debpath
  91     debarchive = file.path(dirname(pkg$archive)
  92                           ,paste(pkg$srcname,'_'
  93                                 ,pkg$version,'.orig.tar.gz'
  94                                 ,sep=''))
  95     wd <- getwd()
  96     setwd(dirname(pkg$path))
  97     # remove them pesky +x files
  98     # BUT EXCLUDE configure and cleanup
  99     log_system('find',shQuote(basename(pkg$path))
 100                 ,'-type f -a '
 101                 ,   '! \\( -name configure -o -name cleanup \\)'
 102                 ,'-exec chmod -x {} \\;')
 103     # tar it all back up
 104     log_system('tar -czf',shQuote(debarchive),shQuote(basename(pkg$path)))
 105     setwd(wd)
 106     file.remove(pkg$archive)
 107     pkg$archive = debarchive
 108     pkg$need_repack = FALSE
 109     return(pkg)
 110 }
 111
 112 prepare_pkg <- function(dir, pkgname) {
 113     # download and extract an R package named pkgname
 114     # OR the bundle containing pkgname
 115
 116     # based loosely on library/utils/R/packages2.R::install.packages
 117
 118     # first a little trick; change pkgname if pkgname is contained in a bundle
 119     if (!(pkgname %in% rownames(available))) {
 120         bundle <- r_bundle_of(pkgname)
 121         if (is.null(bundle)) {
 122             fail('package',pkgname,'is unavailable')
 123         }
 124         pkgname <- bundle
 125     }
 126
 127     # grab the archive and some metadata
 128     pkg <- download_pkg(dir, pkgname)
 129
 130     # now extract the archive
 131     if (!length(grep('\\.tar\\.gz',pkg$archive))) {
 132         fail('archive is not tarball')
 133     }
 134     wd <- getwd()
 135     setwd(dir)
 136     ret = log_system('tar','xzf',shQuote(pkg$archive))
 137     setwd(wd)
 138     if (ret != 0) {
 139         fail('Extraction of archive',pkg$archive,'failed.')
 140     }
 141
 142     # if necessary, repack the archive into Debian-conformant format
 143     if (pkg$need_repack) {
 144         pkg <- repack_pkg(pkg)
 145     }
 146     if (!file.info(pkg$path)[,'isdir']) {
 147         fail(pkg$path,'is not a directory and should be.')
 148     }
 149
 150     # extract the DESCRIPTION file, which contains much metadata
 151     pkg$description = read.dcf(file.path(pkg$path,'DESCRIPTION'))
 152
 153     # ensure consistency of version numbers
 154     if ('Version' %in% names(pkg$description[1,])) {
 155         if (pkg$description[1,'Version'] != available[pkg$name,'Version']) {
 156             # should never happen since available is the basis upon which the
 157             # package is retrieved.
 158             error('available version:',available[pkg$name,'Version'])
 159             error('package version:',pkg$description[1,'Version'])
 160             fail('inconsistency between R package version and cached R version')
 161         }
 162     }
 163
 164     pkg$is_bundle = 'Bundle' %in% names(pkg$description[1,])
 165     # note subtly of short circuit operators (no absorption)
 166     if ((!pkg$is_bundle && pkg$description[1,'Package'] != pkg$name) ||
 167         ( pkg$is_bundle && pkg$description[1,'Bundle'] != pkg$name)) {
 168         fail('package name mismatch')
 169     }
 170     return(pkg)
 171 }
 172