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