trunk/R/license.R

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