1. class CompUnit::Repository::FileSystem { ... }
  2. class CompUnit::Repository::Installation { ... }
  3. class CompUnit::Repository::AbsolutePath { ... }
  4. class CompUnit::Repository::Unknown { ... }
  5. class CompUnit::Repository::NQP { ... }
  6. class CompUnit::Repository::Perl5 { ... }
  7. class CompUnit::RepositoryRegistry {
  8. my $lock = Lock.new;
  9. method repository-for-spec(Str $spec, CompUnit::Repository :$next-repo) {
  10. state %include-spec2cur;
  11. state $lock = Lock.new;
  12. my ($short-id,%options,$path) := parse-include-spec($spec);
  13. my $class := short-id2class($short-id);
  14. return CompUnit::Repository::Unknown.new(:path-spec($spec), :short-name($short-id))
  15. if so $class && nqp::istype($class, Failure) or $class === Any;
  16. my $abspath = $class.?absolutify($path) // $path;
  17. my $id = "$short-id#$abspath";
  18. %options<next-repo> = $next-repo if $next-repo;
  19. $lock.protect( {
  20. %include-spec2cur{$id}:exists
  21. ?? %include-spec2cur{$id}
  22. !! (%include-spec2cur{$id} := $class.new(:prefix($abspath), |%options));
  23. } );
  24. }
  25. my $custom-lib := nqp::hash();
  26. method setup-repositories() {
  27. my $raw-specs;
  28. # only look up environment once
  29. my $ENV := nqp::getattr(%*ENV,Map,'$!storage');
  30. # starting up for creating precomp
  31. my $precomp-specs = nqp::existskey($ENV,'RAKUDO_PRECOMP_WITH')
  32. ?? nqp::atkey($ENV,'RAKUDO_PRECOMP_WITH')
  33. !! False;
  34. if $precomp-specs {
  35. # assume well formed strings
  36. $raw-specs := nqp::split(',', $precomp-specs);
  37. }
  38. # normal start up
  39. else {
  40. $raw-specs := nqp::list();
  41. for Rakudo::Internals.INCLUDE -> $specs {
  42. nqp::push($raw-specs,nqp::unbox_s($_))
  43. for parse-include-specS($specs);
  44. }
  45. if nqp::existskey($ENV,'RAKUDOLIB') {
  46. nqp::push($raw-specs,nqp::unbox_s($_))
  47. for parse-include-specS(nqp::atkey($ENV,'RAKUDOLIB'));
  48. }
  49. if nqp::existskey($ENV,'PERL6LIB') {
  50. nqp::push($raw-specs,nqp::unbox_s($_))
  51. for parse-include-specS(nqp::atkey($ENV,'PERL6LIB'));
  52. }
  53. }
  54. my $prefix := nqp::existskey($ENV,'RAKUDO_PREFIX')
  55. ?? nqp::atkey($ENV,'RAKUDO_PREFIX')
  56. !! nqp::concat(
  57. nqp::atkey(nqp::getcomp('perl6').config,'prefix'),
  58. '/share/perl6'
  59. );
  60. # XXX Various issues with this stuff on JVM , TEMPORARY
  61. try {
  62. if nqp::existskey($ENV,'HOME')
  63. ?? nqp::atkey($ENV,'HOME')
  64. !! nqp::concat(
  65. (nqp::existskey($ENV,'HOMEDRIVE')
  66. ?? nqp::atkey($ENV,'HOMEDRIVE') !! ''),
  67. (nqp::existskey($ENV,'HOMEPATH')
  68. ?? nqp::atkey($ENV,'HOMEPATH') !! '')
  69. ) -> $home {
  70. my str $path = "inst#$home/.perl6";
  71. nqp::bindkey($custom-lib,'home',$path);
  72. nqp::push($raw-specs, $path) unless $precomp-specs;
  73. }
  74. }
  75. # set up custom libs
  76. my str $site = "inst#$prefix/site";
  77. nqp::bindkey($custom-lib,'site',$site);
  78. nqp::push($raw-specs, $site) unless $precomp-specs;
  79. my str $vendor = "inst#$prefix/vendor";
  80. nqp::bindkey($custom-lib,'vendor',$vendor);
  81. nqp::push($raw-specs, $vendor) unless $precomp-specs;
  82. my str $perl = "inst#$prefix";
  83. nqp::bindkey($custom-lib,'perl',$perl);
  84. nqp::push($raw-specs, $perl) unless $precomp-specs;
  85. # your basic repo chain
  86. my CompUnit::Repository $next-repo :=
  87. $precomp-specs
  88. ?? CompUnit::Repository
  89. !! CompUnit::Repository::AbsolutePath.new(
  90. :next-repo( CompUnit::Repository::NQP.new(
  91. :next-repo(CompUnit::Repository::Perl5.new(
  92. ))
  93. )
  94. )
  95. );
  96. my %repos;
  97. my $SPEC := $*SPEC;
  98. sub normalize(\spec){
  99. my $parts := nqp::split('#', spec);
  100. my $path := nqp::elems($parts) - 1;
  101. nqp::bindpos($parts, $path, nqp::unbox_s($SPEC.canonpath(nqp::atpos($parts, $path))));
  102. nqp::join('#', $parts)
  103. };
  104. # create reverted, unique list of path-specs
  105. my $iter := nqp::iterator($raw-specs);
  106. my $unique := nqp::hash();
  107. my $specs := nqp::list();
  108. while $iter {
  109. my str $path-spec = normalize(nqp::shift($iter));
  110. unless nqp::existskey($unique,$path-spec) {
  111. nqp::bindkey($unique,$path-spec,1);
  112. nqp::unshift($specs,$path-spec);
  113. }
  114. }
  115. # convert path-specs to repos
  116. $iter := nqp::iterator($specs);
  117. my $repos := nqp::hash();
  118. while $iter {
  119. my str $spec = nqp::shift($iter);
  120. $next-repo := self.use-repository(
  121. self.repository-for-spec($spec), :current($next-repo));
  122. nqp::bindkey($repos,$spec,$next-repo);
  123. }
  124. # convert custom-lib path-specs to repos
  125. $iter := nqp::iterator($custom-lib);
  126. while $iter {
  127. my \pair = nqp::shift($iter);
  128. my $repo := nqp::atkey($repos, normalize(nqp::iterval(pair)));
  129. if nqp::isnull($repo) {
  130. nqp::deletekey($custom-lib, nqp::iterkey_s(pair));
  131. }
  132. else {
  133. nqp::bindkey($custom-lib, nqp::iterkey_s(pair), $repo);
  134. }
  135. }
  136. $next-repo
  137. }
  138. method !remove-from-chain(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) {
  139. my $item = $current;
  140. while $item {
  141. if $item.next-repo === $repo {
  142. $item.next-repo = $repo.next-repo;
  143. last;
  144. }
  145. $item = $item.next-repo;
  146. }
  147. }
  148. method use-repository(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) {
  149. return $repo if $current === $repo;
  150. self!remove-from-chain($repo, :$current);
  151. $repo.next-repo = $current;
  152. PROCESS::<$REPO> := $repo;
  153. }
  154. method repository-for-name(Str:D \name) {
  155. $*REPO; # initialize if not yet done
  156. my str $name = nqp::unbox_s(name);
  157. nqp::existskey($custom-lib,$name)
  158. ?? nqp::atkey($custom-lib,$name)
  159. !! Nil
  160. }
  161. method register-name($name, CompUnit::Repository $repo) {
  162. nqp::bindkey($custom-lib, $name, $repo);
  163. }
  164. method name-for-repository(CompUnit::Repository $repo) {
  165. $*REPO; # initialize if not yet done
  166. my $iter := nqp::iterator($custom-lib);
  167. while $iter {
  168. my \pair = nqp::shift($iter);
  169. return nqp::iterkey_s(pair) if nqp::iterval(pair).prefix eq $repo.prefix;
  170. }
  171. Nil
  172. }
  173. method file-for-spec(Str $spec) {
  174. my @parts = $spec.split('#', 2);
  175. if @parts.elems == 2 {
  176. my $repo = self.repository-for-name(@parts[0]);
  177. return $repo.source-file(@parts[1]) if $repo.can('source-file');
  178. }
  179. Nil
  180. }
  181. method head() { # mostly usefull for access from NQP
  182. $*REPO
  183. }
  184. method resolve-unknown-repos(@repos) {
  185. # Cannot just use GLOBAL.WHO here as that gives a BOOTHash
  186. my $global := nqp::list("GLOBAL");
  187. for @repos.pairs {
  188. if nqp::istype($_.value, CompUnit::Repository::Unknown) {
  189. my $i = $_.key;
  190. my $next-repo := @repos[$i + 1];
  191. my $head := PROCESS<$REPO>;
  192. PROCESS::<$REPO> := $next-repo;
  193. my $comp_unit = $next-repo.need(
  194. CompUnit::DependencySpecification.new(:short-name($_.value.short-name))
  195. );
  196. PROCESS::<$REPO> := $head;
  197. $*W.find_symbol($global).WHO.merge-symbols($comp_unit.handle.globalish-package);
  198. my $new-repo = self.repository-for-spec($_.value.path-spec, :$next-repo);
  199. if $i > 0 {
  200. @repos[$i - 1].next-repo = $new-repo if $i > 0;
  201. }
  202. else {
  203. PROCESS::<$REPO> := $new-repo;
  204. }
  205. }
  206. }
  207. }
  208. # Handles any object repossession conflicts that occurred during module load,
  209. # or complains about any that cannot be resolved.
  210. method resolve_repossession_conflicts(@conflicts) {
  211. for @conflicts -> $orig is raw, $current is raw {
  212. # If it's a Stash in conflict, we make sure any original entries get
  213. # appropriately copied.
  214. if $orig.HOW.name($orig) eq 'Stash' {
  215. $current.merge-symbols($orig);
  216. }
  217. # We could complain about anything else, and may in the future; for
  218. # now, we let it pass by with "latest wins" semantics.
  219. }
  220. }
  221. sub short-id2class(Str:D $short-id) {
  222. state %short-id2class;
  223. state $lock = Lock.new;
  224. Proxy.new(
  225. FETCH => {
  226. $lock.protect( {
  227. if %short-id2class.EXISTS-KEY($short-id) {
  228. %short-id2class.AT-KEY($short-id);
  229. }
  230. else {
  231. my $type = try ::($short-id);
  232. if $type !=== Any {
  233. if $type.?short-id -> $id {
  234. if %short-id2class.EXISTS-KEY($id) {
  235. %short-id2class.AT-KEY($id);
  236. }
  237. else {
  238. %short-id2class.BIND-KEY($id, $type);
  239. }
  240. }
  241. else {
  242. die "Class '$type.^name()' is not a CompUnit::Repository";
  243. }
  244. }
  245. else {
  246. Any
  247. }
  248. }
  249. } );
  250. },
  251. STORE => -> $, $class {
  252. my $type = ::($class);
  253. die "Must load class '$class' first" if nqp::istype($type,Failure);
  254. $lock.protect( { %short-id2class{$short-id} := $type } );
  255. },
  256. );
  257. }
  258. # prime the short-id -> class lookup
  259. short-id2class('file') = 'CompUnit::Repository::FileSystem';
  260. short-id2class('inst') = 'CompUnit::Repository::Installation';
  261. short-id2class('ap') = 'CompUnit::Repository::AbsolutePath';
  262. short-id2class('nqp') = 'CompUnit::Repository::NQP';
  263. short-id2class('perl5') = 'CompUnit::Repository::Perl5';
  264. sub parse-include-spec(Str:D $spec, Str:D $default-short-id = 'file') {
  265. my %options;
  266. # something we understand
  267. if $spec ~~ /^
  268. [
  269. $<type>=[ <.ident>+ % '::' ]
  270. [ '#' $<n>=\w+
  271. <[ < ( [ { ]> $<v>=<[\w-]>+ <[ > ) \] } ]>
  272. { %options{$<n>} = ~$<v> }
  273. ]*
  274. '#'
  275. ]?
  276. $<path>=.*
  277. $/ {
  278. ( $<type> ?? ~$<type> !! $default-short-id, %options, ~$<path> );
  279. }
  280. }
  281. sub parse-include-specS(Str:D $specs) {
  282. my @found;
  283. my $default-short-id = 'file';
  284. if $*RAKUDO_MODULE_DEBUG -> $RMD { $RMD("Parsing specs: $specs") }
  285. # for all possible specs
  286. for $specs.split(',') -> $spec {
  287. if parse-include-spec($spec.trim, $default-short-id) -> $triplet {
  288. @found.push: join "#",
  289. $triplet[0],
  290. $triplet[1].map({ .key ~ "<" ~ .value ~ ">" }),
  291. $triplet[2];
  292. $default-short-id = $triplet[0];
  293. }
  294. elsif $spec {
  295. die "Don't know how to handle $spec";
  296. }
  297. }
  298. @found;
  299. }
  300. }