trunk/R/getrpkg.R

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