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