180 lines
12 KiB
Racket
180 lines
12 KiB
Racket
#lang racket/base
|
|
(require rackunit
|
|
pkg/name
|
|
"util.rkt")
|
|
|
|
(this-test-is-run-by-the-main-test)
|
|
|
|
(define-syntax check-equal-values?
|
|
(syntax-rules (values)
|
|
[(_ expr (values a ...))
|
|
(check-equal? (call-with-values (lambda () expr) list) (list a ...))]))
|
|
|
|
(define (parse a b [bad-rx #f]
|
|
#:link-dirs? [link-dirs? #f])
|
|
(define reason #f)
|
|
(define-values (name type) (package-source->name+type
|
|
a b
|
|
#:link-dirs? link-dirs?
|
|
#:must-infer-name? #f
|
|
#:complain (lambda (s r)
|
|
(unless reason (set! reason r)))))
|
|
(values name
|
|
type
|
|
(if reason
|
|
(if bad-rx
|
|
(not (regexp-match? bad-rx reason))
|
|
#f)
|
|
(not bad-rx))))
|
|
|
|
(define (run-pkg-tests)
|
|
(check-equal-values? (parse "" #f #rx"ill-formed") (values #f #f #f))
|
|
|
|
(check-equal-values? (parse "fish" #f) (values "fish" 'name #t))
|
|
(check-equal-values? (parse "fish" 'name) (values "fish" 'name #t))
|
|
(check-equal-values? (parse "fish!" 'name #rx"disallowed") (values #f 'name #f))
|
|
(check-equal-values? (parse "fish/" 'name #rx"disallowed") (values #f 'name #f))
|
|
(check-equal-values? (parse "fish123A_B-C" 'name) (values "fish123A_B-C" 'name #t))
|
|
(check-equal-values? (parse "fish123A_B-C!" 'name #rx"disallowed") (values #f 'name #f))
|
|
|
|
(check-equal-values? (parse "fish.plt" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.zip" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.tar" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.tgz" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.tar.gz" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "ocean/fish.tar.gz" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.plt" 'file) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.tar.gz" 'file) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "fish.other" 'file #rx"archive") (values #f 'file #f))
|
|
(check-equal-values? (parse "fish" 'file #rx"archive") (values #f 'file #f))
|
|
(check-equal-values? (parse "fish!" 'file #rx"archive") (values #f 'file #f))
|
|
(check-equal-values? (parse "" 'file #rx"ill-formed") (values #f 'file #f))
|
|
|
|
(check-equal-values? (parse "fish/" #f) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "./fish" #f) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "sub/fish" #f) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "fish/" 'dir) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "fish/" 'link) (values "fish" 'link #t))
|
|
(check-equal-values? (parse "fish" 'dir) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "fish!/" 'dir) (values #f 'dir #t))
|
|
(check-equal-values? (parse "/" 'dir #rx"no elements in path") (values #f 'dir #f))
|
|
(check-equal-values? (parse (path->string (build-path 'same)) 'dir #rx"ending path") (values #f 'dir #f))
|
|
|
|
(check-equal-values? (parse "fish/" #f #:link-dirs? #t) (values "fish" 'link #t))
|
|
(check-equal-values? (parse "fish/" 'dir #:link-dirs? #t) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "fish.plt" #f #:link-dirs? #t) (values "fish" 'file #t))
|
|
|
|
(check-equal? (package-source->name "http://") #f)
|
|
(check-equal-values? (parse "http://" #f #rx"path is empty") (values #f 'dir-url #f))
|
|
|
|
(check-equal-values? (parse "http://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
|
(check-equal-values? (parse "https://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish.tar.gz" #f) (values "fish" 'file-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish" 'file-url #rx"archive") (values #f 'file-url #f))
|
|
(check-equal-values? (parse "fish.zip" 'file-url) (values "fish" 'file-url #t))
|
|
(check-equal-values? (parse "dir/fish.zip" 'file-url) (values "fish" 'file-url #t))
|
|
(check-equal-values? (parse "fish/" 'file-url #rx"archive") (values #f 'file-url #f))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish!.zip" 'file-url) (values #f 'file-url #t))
|
|
|
|
(check-equal-values? (parse "http://racket-lang.org/fish/" #f) (values "fish" 'dir-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish/" 'dir-url) (values "fish" 'dir-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish" 'dir-url) (values "fish" 'dir-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish.plt" 'dir-url) (values #f 'dir-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/fish" #f) (values "fish" 'dir-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/." 'file-url #rx"indicator") (values #f 'file-url #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/.." 'file-url #rx"indicator") (values #f 'file-url #t))
|
|
|
|
(check-equal-values? (parse "github://notgithub.com/racket/fish/master" #f #rx"github.com") (values #f 'github #f))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/master" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish.rkt/master" #f) (values #f 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/release" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish" #f) (values "catfish" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish/" #f) (values "catfish" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish/bill" #f) (values "bill" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/master" 'github) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "github://github.com/fish/master" 'github #rx"three") (values #f 'github #f))
|
|
(check-equal-values? (parse "github://github.com/racket/fish.more/release" 'github) (values #f 'github #t))
|
|
(check-equal-values? (parse "github://github.com/racket/./release" #f #rx"indicator") (values #f 'github #f))
|
|
(check-equal-values? (parse "github://github.com/../fish/release" #f #rx"indicator") (values #f 'github #f))
|
|
(check-equal-values? (parse "github://github.com/racket/fish/master" 'clone) (values "fish" 'clone #t))
|
|
(check-equal-values? (parse "github://github.com/fish/master" 'clone #rx"three") (values #f 'clone #f))
|
|
|
|
(check-equal-values? (parse "git://github.com/racket/fish" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish/" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish.git" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish.git/" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish.rkt" #f) (values #f 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish#release" #f) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish#release" #f) (values "catfish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish/" #f) (values "catfish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish?path=catfish/bill" #f) (values "bill" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish/?path=catfish/bill" #f) (values "bill" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish/master" 'github #rx"two") (values #f 'github #f))
|
|
(check-equal-values? (parse "git://github.com/racket/fish.more" 'github) (values #f 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/." #f #rx"indicator") (values #f 'github #f))
|
|
(check-equal-values? (parse "git://github.com/../fish" #f #rx"indicator") (values #f 'github #f))
|
|
(check-equal-values? (parse "git://github.com/racket/fish" 'clone) (values "fish" 'clone #t))
|
|
(check-equal-values? (parse "racket/fish" 'github) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "git://github.com/racket/fish/?path=../bill" #f #rx"indicator") (values #f 'github #f))
|
|
|
|
(check-equal-values? (parse "git://not-github.com/racket/fish" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/fish" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/fish.git" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/fish.git/" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/" #f #rx"empty") (values #f 'git #f))
|
|
(check-equal-values? (parse "git://not-github.com/fish.git//" #f #rx"empty") (values #f 'git #f))
|
|
(check-equal-values? (parse "git://not-github.com/fish#release" #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/fish?path=catfish/bill" #f) (values "bill" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/fish/?path=catfish/bill" #f) (values "bill" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/../fish.git/" #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "git://not-github.com/.././" #f #rx"indicator") (values #f 'git #f))
|
|
(check-equal-values? (parse "git://not-github.com/racket/fish" 'clone #f) (values "fish" 'clone #t))
|
|
(check-equal-values? (parse "git://not-github.com/.././" 'clone #rx"indicator") (values #f 'clone #f))
|
|
(check-equal-values? (parse "git://not-github.com/fish/?path=../bill" #f #rx"indicator") (values #f 'git #f))
|
|
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish" 'git #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "https://racket-lang.org/racket/fish" 'git #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "https://racket-lang.org/racket/fish?path=catfish" 'git #f) (values "catfish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git" 'git #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git/" 'git #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git/" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git#release" #f #f) (values "fish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/fish.git?path=catfish" #f #f) (values "catfish" 'git #t))
|
|
(check-equal-values? (parse "http://racket-lang.org/racket/.." 'git #rx"indicator") (values #f 'git #f))
|
|
|
|
(check-equal-values? (parse "racket/fish" 'github) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "racket/fish.git" 'github) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "racket/fish/" 'github) (values "fish" 'github #t))
|
|
(check-equal-values? (parse "racket/fish/x" 'github #rx"two") (values #f 'github #f))
|
|
(check-equal-values? (parse "fish" 'github #rx"two") (values #f 'github #f))
|
|
|
|
(check-equal-values? (parse "file://fish.plt" #f) (values #f 'dir #t)) ; missing root means an empty path
|
|
(check-equal-values? (parse "file:///root/fish.plt" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "file://fish" #f) (values #f 'dir #t)) ; missing root means an empty path
|
|
(check-equal-values? (parse "file:///root/fish" #f) (values "fish" 'dir #t))
|
|
(check-equal-values? (parse "file:///root/fish.zip?ignored=yes#alsoIgnored" #f) (values "fish" 'file #t))
|
|
(check-equal-values? (parse "file:///root/fish?ignored=yes#alsoIgnored" #f) (values "fish" 'dir #t))
|
|
|
|
(check-equal-values? (parse "file:///root/fish?type=link" #f) (values "fish" 'link #t))
|
|
(check-equal-values? (parse "file:///root/fish?type=static-link" #f) (values "fish" 'static-link #t))
|
|
(check-equal-values? (parse "file:///root/fish?type=sink" #f #rx"unrecognized") (values #f 'dir #f))
|
|
|
|
(check-equal-values? (parse "random://racket-lang.org/fish.plt" #f #rx"scheme") (values #f #f #f))
|
|
|
|
(check-equal-values? (parse "" #f) (values #f #f #f))
|
|
(check-equal-values? (parse "" 'file) (values #f 'file #f))
|
|
(check-equal-values? (parse "" 'link) (values #f 'link #f))
|
|
(check-equal-values? (parse "" 'static-link) (values #f 'static-link #f))
|
|
(check-equal-values? (parse "" 'file-url) (values #f 'file-url #f))
|
|
(check-equal-values? (parse "" 'dir-url) (values #f 'dir-url #f))
|
|
(check-equal-values? (parse "" 'git) (values #f 'git #f))
|
|
(check-equal-values? (parse "" 'github #rx"two path elements") (values #f 'github #f))
|
|
|
|
(void))
|
|
|
|
(provide run-pkg-tests)
|
|
|
|
(module+ main
|
|
(run-pkg-tests* run-pkg-tests))
|