trunk/R/license.R

   1 is_acceptable_license <- function(license,verbose=FALSE,debug=FALSE) {
   2     if (verbose) cat("is_acceptable_license: license: ",
   3                         #paste(license,collapse="@",sep=""),
   4                         license,
   5                         "'\n",sep="")
   6     # determine if license text is acceptable
   7
   8     if (length(grep('^file ',license))) {
   9         # skip file licenses
  10         notice("The package has a file license. This needs individual checking and settings in the respective table.")
  11         return(FALSE)
  12     }
  13     license <- license_text_reduce(license)
  14     if (debug) cat("**** a ****\n")
  15     action = db_license_override_name(license)
  16     if (verbose) {
  17         cat("**** action: ****\n")
  18         print(action)
  19     }
  20     if (!is.null(action)) {
  21         if (debug) cat("**** c1 ****\n")
  22         #return(isTRUE(action))
  23         return(TRUE)
  24     }
  25     if (debug) cat("**** c ****\n")
  26     license <- license_text_further_reduce(license)
  27     if (debug) cat("**** d ****\n")
  28     action = db_license_override_name(license)
  29     if (debug) cat("**** e ****\n")
  30     if (!is.null(action)) {
  31         warn('Accepting/rejecting wild license as',license,'. FIX THE PACKAGE!')
  32         return(action)
  33     }
  34     license <- license_text_extreme_reduce(license)
  35     if (debug) cat("**** f ****\n")
  36     action = db_license_override_name(license)
  37     if (debug) cat("**** g ****\n")
  38     if (!is.null(action)) {
  39         warn('Accepting/rejecting wild license as',license,'. FIX THE PACKAGE!')
  40         return(action)
  41     }
  42     error('is_acceptable_license: Wild license',license,'did not match classic rules; rejecting.')
  43     return(F)
  44 }
  45
  46 license_text_reduce <- function(license,verbose=FALSE,debug=FALSE) {
  47     if (verbose) cat("license_text_reduce license:",license,"\n",sep="")
  48     # these reduction steps are sound for all conformant R license
  49     # specifications.
  50
  51     if (Encoding(license) == "unknown")
  52         Encoding(license) <- "latin1"   # or should it be UTF-8 ?
  53
  54     ## compress spaces into a single space
  55     license = gsub('[[:space:]]+',' ',license)
  56     # make all characters lower case
  57     license = tolower(license)
  58     # don't care about versions of licenses
  59     license = chomp(sub('\\( ?[<=>!]+ ?[0-9.-]+ ?\\)',''
  60                     ,sub('-[0-9.-]+','',license)))
  61     # remove any extra space introduced
  62     license = chomp(gsub('[[:space:]]+',' ',license))
  63     if (debug) cat("license_text_reduce: ",license,"\n",sep="")
  64     return(license)
  65 }
  66
  67 license_text_further_reduce <- function(license,verbose=TRUE) {
  68     if (verbose) cat("license_text_further_reduce license:",license,"\n",sep="")
  69     # these reduction steps are heuristic and may lead to
  70     # in correct acceptances, if care is not taken.
  71
  72     # uninteresting urls
  73     license = gsub('http://www.gnu.org/[[:alnum:]/._-]*','',license)
  74     license = gsub('http://www.x.org/[[:alnum:]/._-]*','',license)
  75     license = gsub('http://www.opensource.org/[[:alnum:]/._-]*','',license)
  76     # remove all punctuation
  77     license = gsub('[[:punct:]]+','',license)
  78     # remove any extra space introduced
  79     license = chomp(gsub('[[:space:]]+',' ',license))
  80     # redundant
  81     license = gsub('the','',license)
  82     license = gsub('see','',license)
  83     license = gsub('standard','',license)
  84     license = gsub('licen[sc]e','',license)
  85     license = gsub('(gnu )?(gpl|general public)','gpl',license)
  86     license = gsub('(mozilla )?(mpl|mozilla public)','mpl',license)
  87     # remove any extra space introduced
  88     license = chomp(gsub('[[:space:]]+',' ',license))
  89     return(license)
  90 }
  91
  92 license_text_extreme_reduce <- function(license,verbose=TRUE) {
  93     if (verbose) cat("license_text_extreme_reduce license:",license,"\n",sep="")
  94     # remove everything that may or may not be a version specification
  95     license = gsub('(ver?sion|v)? *[0-9.-]+ *(or *(higher|later|newer|greater|above))?',''
  96                    ,license)
  97     # remove any extra space introduced
  98     license = chomp(gsub('[[:space:]]+',' ',license))
  99     return(license)
 100 }
 101
 102 license_text_hash_reduce <- function(text,verbose=TRUE) {
 103     if (verbose) cat("license_text_hash_reduce text:",text,"\n",sep="")
 104     # reduction of license text, suitable for hashing.
 105     return(chomp(tolower(gsub('[[:space:]]+',' ',text))))
 106 }
 107
 108 get_license <- function(pkg,license,verbose=FALSE) {
 109     license <- gsub('[[:space:]]+$',' ',license)
 110     if (length(grep('^file\\s',license))) {
 111         notice("License recognised as 'file'-based license.")
 112         if (length(grep('^file\\s+LICEN[CS]E$',license))) {
 113             file = gsub('file\\s+','',license)
 114             path = file.path(pkg$path, file)
 115             if (file.exists(path)) {
 116                 license <- readChar(path,file.info(path)$size)
 117             } else {
 118                 path = file.path(pkg$path, 'inst', file)
 119                 if (file.exists(path)) {
 120                     license <- readChar(path,file.info(path)$size)
 121                 } else {
 122                     error(paste("Could not locate license file expected at '",
 123                                 path,"' or at '",
 124                                 file.path(pkg$path, file),"'.\n",sep=""))
 125                 }
 126             }
 127         } else {
 128             error("invalid license file specification, expected 'LICENSE' as filename, got: ",license)
 129             return(NA)
 130         }
 131     }
 132     return(license)
 133 }
 134
 135 get_license_hash <- function(pkg,license,verbose=FALSE) {
 136     return(digest(get_license(pkg,license,verbose=verbose),algo='sha1',serialize=FALSE))
 137 }
 138
 139 is_acceptable_hash_license <- function(pkg,license,verbose=TRUE,debug=TRUE) {
 140     if (debug) cat(paste("is_acceptable_hash_license: pkg$name='",pkg$name,"', license='",license,"'.\n",sep=""))
 141     license_sha1 <- get_license_hash(pkg,license,verbose=verbose)
 142     if (is.null(license_sha1)) {
 143         if (verbose) cat("is_acceptable_hash_license: get_license_hash(pkg,license) returned NULL, returning FALSE.\n")
 144         return(FALSE)
 145     } else if (verbose) {
 146         notice(paste("is_acceptable_hash_license, license_sha1 determined: '",license_sha1,"'",sep=""))
 147     }
 148     action = db_license_override_hash(license_sha1)
 149     if (is.null(action)) {
 150         if (verbose) cat("is_acceptable_hash_license: get_license_override_hash(license_sha1) returned NULL, returning FALSE.\n")
 151         action = FALSE
 152     } else if (0 == length(action)) {
 153         notice("An error occurred, 0==length(action), ignoring package.\n")
 154         action = FALSE
 155     } else if (is.na(action)) {
 156         notice("An error occurred, is.na(action), ignoring package.\n")
 157         action = FALSE
 158     }
 159     if (action) {
 160         warn('Wild license',license,'accepted via hash',license_sha1)
 161     }
 162     return(action)
 163 }
 164
 165
 166 accept_license <- function(pkg,verbose=TRUE) {
 167     # check the license
 168     if (!('License' %in% names(pkg$description[1,]))) {
 169         fail('package has no License: field in description!')
 170         return(NULL)
 171     }
 172     accept=NULL
 173     if (verbose) { cat("accept_license: pkg:\n"); print(pkg$srcname) }
 174     license<-pkg$description[1,'License']
 175     if (verbose) { cat("                license:\n"); print(license) }
 176
 177     for (l in strsplit(chomp(license),'[[:space:]]*\\|[[:space:]]*')[[1]]) {
 178         if (verbose) cat("Investigating: '",l,"'\n",sep="")
 179         if (is_acceptable_license(l)) {
 180             accept=l
 181             break
 182         } else if (is_acceptable_hash_license(pkg,l,verbose=verbose)) {
 183             accept=l
 184             break
 185         } else {
 186             notice(paste("Could not accept license ",l," for package ",pkg,"\n",sep=""))
 187         }
 188     }
 189     if (is.null(accept)) {
 190         fail('No acceptable license:',pkg$description[1,'License'])
 191     } else {
 192         notice('Auto-accepted license',accept)
 193     }
 194     if (accept == 'Unlimited') {
 195         # definition of Unlimited from ``Writing R extensions''
 196         accept=paste('Unlimited (no restrictions on distribution or'
 197                     ,'use other than those imposed by relevant laws)')
 198     }
 199     return(accept)
 200 }