trunk/R/license.R

   1 is_acceptable_license <- function(license) {
   2     # determine if license text is acceptable
   3
   4     if (length(grep('^file ',license))) {
   5         # skip file licenses
   6         return(FALSE)
   7     }
   8     license <- license_text_reduce(license)
   9     action = db_license_override_name(license)
  10     if (!is.null(action)) {
  11         return(action)
  12     }
  13     license <- license_text_further_reduce(license)
  14     action = db_license_override_name(license)
  15     if (!is.null(action)) {
  16         warn('Accepting/rejecting wild license as',license,'. FIX THE PACKAGE!')
  17         return(action)
  18     }
  19     license <- license_text_extreme_reduce(license)
  20     action = db_license_override_name(license)
  21     if (!is.null(action)) {
  22         warn('Accepting/rejecting wild license as',license,'. FIX THE PACKAGE!')
  23         return(action)
  24     }
  25     error('Wild license',license,'did not match classic rules; rejecting')
  26     return(F)
  27 }
  28
  29 license_text_reduce <- function(license) {
  30     # these reduction steps are sound for all conformant R license
  31     # specifications.
  32
  33     # compress spaces into a single space
  34     license = gsub('[[:space:]]+',' ',license)
  35     # make all characters lower case
  36     license = tolower(license)
  37     # don't care about versions of licenses
  38     license = chomp(sub('\\( ?[<=>!]+ ?[0-9.-]+ ?\\)',''
  39                     ,sub('-[0-9.-]+','',license)))
  40     # remove any extra space introduced
  41     license = chomp(gsub('[[:space:]]+',' ',license))
  42     return(license)
  43 }
  44
  45 license_text_further_reduce <- function(license) {
  46     # these reduction steps are heuristic and may lead to
  47     # in correct acceptances, if care is not taken.
  48
  49     # uninteresting urls
  50     license = gsub('http://www.gnu.org/[[:alnum:]/._-]*','',license)
  51     license = gsub('http://www.x.org/[[:alnum:]/._-]*','',license)
  52     license = gsub('http://www.opensource.org/[[:alnum:]/._-]*','',license)
  53     # remove all punctuation
  54     license = gsub('[[:punct:]]+','',license)
  55     # remove any extra space introduced
  56     license = chomp(gsub('[[:space:]]+',' ',license))
  57     # redundant
  58     license = gsub('the','',license)
  59     license = gsub('see','',license)
  60     license = gsub('standard','',license)
  61     license = gsub('licen[sc]e','',license)
  62     license = gsub('(gnu )?(gpl|general public)','gpl',license)
  63     license = gsub('(mozilla )?(mpl|mozilla public)','mpl',license)
  64     # remove any extra space introduced
  65     license = chomp(gsub('[[:space:]]+',' ',license))
  66     return(license)
  67 }
  68
  69 license_text_extreme_reduce <- function(license) {
  70     # remove everything that may or may not be a version specification
  71     license = gsub('(ver?sion|v)? *[0-9.-]+ *(or *(higher|later|newer|greater|above))?',''
  72                    ,license)
  73     # remove any extra space introduced
  74     license = chomp(gsub('[[:space:]]+',' ',license))
  75     return(license)
  76 }
  77
  78 license_text_hash_reduce <- function(text) {
  79     # reduction of license text, suitable for hashing.
  80     return(chomp(tolower(gsub('[[:space:]]+',' ',text))))
  81 }
  82
  83 get_license <- function(pkg,license) {
  84     license <- chomp(gsub('[[:space:]]+',' ',license))
  85     if (length(grep('^file ',license))) {
  86         if (length(grep('^file LICEN[CS]E$',license))) {
  87             file = gsub('file ','',license)
  88             path = file.path(pkg$path, file)
  89             if (file.exists(path)) {
  90                 license <- license_text_reduce(readChar(path,file.info(path)$size))
  91             } else {
  92                 path = file.path(pkg$path, 'inst', file)
  93                 if (file.exists(path)) {
  94                     license <- license_text_reduce(readChar(path,file.info(path)$size))
  95                 } else {
  96                     error('said to look at a license file but license file is missing')
  97                 }
  98             }
  99         } else {
 100             error('invalid license file specification',license)
 101             return(NA)
 102         }
 103     }
 104     return(license)
 105 }
 106
 107 get_license_hash <- function(pkg,license) {
 108     return(digest(get_license(pkg,license),algo='sha1',serialize=FALSE))
 109 }
 110
 111 is_acceptable_hash_license <- function(pkg,license) {
 112     license_sha1 <- get_license_hash(pkg,license)
 113     if (is.null(license_sha1)) {
 114         return(FALSE)
 115     }
 116     action = db_license_override_hash(license_sha1)
 117     if (is.null(action)) {
 118         action = FALSE
 119     }
 120     if (action) {
 121         warn('Wild license',license,'accepted via hash',license_sha1)
 122     }
 123     return(action)
 124 }
 125
 126
 127 accept_license <- function(pkg) {
 128     # check the license
 129     if (!('License' %in% names(pkg$description[1,]))) {
 130         fail('package has no License: field in description!')
 131     }
 132     accept=NULL
 133     for (license in strsplit(chomp(pkg$description[1,'License'])
 134                             ,'[[:space:]]*\\|[[:space:]]*')[[1]]) {
 135         if (is_acceptable_license(license)) {
 136             accept=license
 137             break
 138         }
 139         if (is_acceptable_hash_license(pkg,license)) {
 140             accept=license
 141             break
 142         }
 143     }
 144     if (is.null(accept)) {
 145         fail('No acceptable license:',pkg$description[1,'License'])
 146     } else {
 147         notice('Auto-accepted license',accept)
 148     }
 149     if (accept == 'Unlimited') {
 150         # definition of Unlimited from ``Writing R extensions''
 151         accept=paste('Unlimited (no restrictions on distribution or'
 152                     ,'use other than those imposed by relevant laws)')
 153     }
 154     return(accept)
 155 }