1. class CompUnit::Repository::Installation does CompUnit::Repository::Locally does CompUnit::Repository::Installable {
  2. has $!cver = nqp::hllize(nqp::atkey(nqp::gethllsym('perl6', '$COMPILER_CONFIG'), 'version'));
  3. has %!loaded;
  4. has $!precomp;
  5. has $!id;
  6. has Int $!version;
  7. has %!dist-metas;
  8. has $!precomp-stores;
  9. has $!precomp-store;
  10. my $verbose := nqp::getenvhash<RAKUDO_LOG_PRECOMP>;
  11. submethod BUILD(:$!prefix, :$!lock, :$!WHICH, :$!next-repo --> Nil) { }
  12. my class InstalledDistribution is Distribution::Hash {
  13. method content($address) {
  14. my $entry = $.meta<provides>.values.first: { $_{$address}:exists };
  15. my $file = $entry
  16. ?? $.prefix.child('sources').child($entry{$address}<file>)
  17. !! $.prefix.child('resources').child($.meta<files>{$address});
  18. $file.open(:r)
  19. }
  20. }
  21. method writeable-path {
  22. $.prefix.w ?? $.prefix !! IO::Path;
  23. }
  24. method !writeable-path {
  25. self.can-install ?? $.prefix !! IO::Path;
  26. }
  27. method can-install() {
  28. $.prefix.w || ?(!$.prefix.e && try { $.prefix.mkdir } && $.prefix.e);
  29. }
  30. my $windows_wrapper = '@rem = \'--*-Perl-*--
  31. @echo off
  32. if "%OS%" == "Windows_NT" goto WinNT
  33. #perl# "%~dpn0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  34. goto endofperl
  35. :WinNT
  36. #perl# "%~dpn0" %*
  37. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  38. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  39. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  40. goto endofperl
  41. @rem \';
  42. __END__
  43. :endofperl
  44. ';
  45. my $perl_wrapper = '#!/usr/bin/env #perl#
  46. sub MAIN(:$name is copy, :$auth, :$ver, *@, *%) {
  47. shift @*ARGS if $name;
  48. shift @*ARGS if $auth;
  49. shift @*ARGS if $ver;
  50. $name //= \'#dist-name#\';
  51. my @installations = $*REPO.repo-chain.grep(CompUnit::Repository::Installable);
  52. my @binaries = flat @installations.map: { .files(\'bin/#name#\', :$name, :$auth, :$ver) };
  53. unless +@binaries {
  54. @binaries = flat @installations.map: { .files(\'bin/#name#\', :$name) };
  55. if +@binaries {
  56. note q:to/SORRY/;
  57. ===SORRY!===
  58. No candidate found for \'#name#\' that match your criteria.
  59. Did you perhaps mean one of these?
  60. SORRY
  61. my %caps = :name([\'Distribution\', 12]), :auth([\'Author(ity)\', 11]), :ver([\'Version\', 7]);
  62. for @binaries -> $dist {
  63. for %caps.kv -> $caption, @opts {
  64. @opts[1] = max @opts[1], ($dist{$caption} // \'\').Str.chars
  65. }
  66. }
  67. note \' \' ~ %caps.values.map({ sprintf(\'%-*s\', .[1], .[0]) }).join(\' | \');
  68. for @binaries -> $dist {
  69. note \' \' ~ %caps.kv.map( -> $k, $v { sprintf(\'%-*s\', $v.[1], $dist{$k} // \'\') } ).join(\' | \')
  70. }
  71. }
  72. else {
  73. note "===SORRY!===\nNo candidate found for \'#name#\'.\n";
  74. }
  75. exit 1;
  76. }
  77. %*ENV<PERL6_PROGRAM_NAME> = $*PROGRAM-NAME;
  78. exit run($*EXECUTABLE, @binaries.sort(*<ver>).tail.hash.<files><bin/#name#>, @*ARGS).exitcode
  79. }';
  80. method !sources-dir() {
  81. my $sources = $.prefix.child('sources');
  82. $sources.mkdir unless $sources.e;
  83. $sources
  84. }
  85. method !resources-dir() {
  86. my $resources = $.prefix.child('resources');
  87. $resources.mkdir unless $resources.e;
  88. $resources
  89. }
  90. method !dist-dir() {
  91. my $dist = $.prefix.child('dist');
  92. $dist.mkdir unless $dist.e;
  93. $dist
  94. }
  95. method !bin-dir() {
  96. my $bin = $.prefix.child('bin');
  97. $bin.mkdir unless $bin.e;
  98. $bin
  99. }
  100. method !add-short-name($name, $dist, $source?) {
  101. my $short-dir = $.prefix.child('short');
  102. my $id = nqp::sha1($name);
  103. my $lookup = $short-dir.child($id);
  104. $lookup.mkdir;
  105. $lookup.child($dist.id).spurt(
  106. "{$dist.meta<ver> // ''}\n"
  107. ~ "{$dist.meta<auth> // ''}\n"
  108. ~ "{$dist.meta<api> // ''}\n"
  109. ~ "{$source // ''}\n"
  110. );
  111. }
  112. method !remove-dist-from-short-name-lookup-files($dist --> Nil) {
  113. my $short-dir = $.prefix.child('short');
  114. return unless $short-dir.e;
  115. my $id = $dist.id;
  116. for $short-dir.dir -> $dir {
  117. $dir.child($id).unlink;
  118. $dir.rmdir unless $dir.dir;
  119. }
  120. }
  121. method !file-id(Str $name, Str $dist-id) {
  122. my $id = $name ~ $dist-id;
  123. nqp::sha1($id)
  124. }
  125. method name(--> Str:D) {
  126. CompUnit::RepositoryRegistry.name-for-repository(self)
  127. }
  128. method !repo-prefix() {
  129. my $repo-prefix = self.name // '';
  130. $repo-prefix ~= '#' if $repo-prefix;
  131. $repo-prefix
  132. }
  133. method !read-dist($id) {
  134. my $dist = Rakudo::Internals::JSON.from-json($.prefix.child('dist').child($id).slurp);
  135. $dist<ver> = $dist<ver> ?? Version.new( ~$dist<ver> ) !! Version.new('0');
  136. $dist
  137. }
  138. method !repository-version(--> Int:D) {
  139. return $!version if defined $!version;
  140. my $version-file = $.prefix.child('version');
  141. return $!version = 0 unless $version-file ~~ :f;
  142. $!version = $version-file.slurp.Int
  143. }
  144. method upgrade-repository() {
  145. my $version = self!repository-version;
  146. my $short-dir = $.prefix.child('short');
  147. mkdir $short-dir unless $short-dir.e;
  148. my $precomp-dir = $.prefix.child('precomp');
  149. mkdir $precomp-dir unless $precomp-dir.e;
  150. self!sources-dir;
  151. my $resources-dir = self!resources-dir;
  152. my $dist-dir = self!dist-dir;
  153. self!bin-dir;
  154. if ($version < 1) {
  155. for $short-dir.dir -> $file {
  156. my @ids = $file.lines.unique;
  157. $file.unlink;
  158. $file.mkdir;
  159. for @ids -> $id {
  160. my $dist = self!read-dist($id);
  161. $file.child($id).spurt("{$dist<ver> // ''}\n{$dist<auth> // ''}\n{$dist<api> // ''}\n");
  162. }
  163. }
  164. }
  165. if ($version < 2) {
  166. for $dist-dir.dir -> $dist-file {
  167. my %meta = Rakudo::Internals::JSON.from-json($dist-file.slurp);
  168. my $files = %meta<files> //= [];
  169. for eager $files.keys -> $file {
  170. $files{"resources/$file"} = $files{$file}:delete
  171. if $resources-dir.child($files{$file}).e
  172. and not $.prefix.child($file).e; # bin/ is already included in the path
  173. }
  174. $dist-file.spurt: Rakudo::Internals::JSON.to-json(%meta);
  175. }
  176. }
  177. $.prefix.child('version').spurt('2');
  178. $!version = 2;
  179. }
  180. proto method install(|) {*}
  181. multi method install($dist, %sources, %scripts?, %resources?, Bool :$force) {
  182. # XXX: Deprecation shim
  183. my %files;
  184. %files{"bin/$_.key()"} = $_.value for %scripts.pairs;
  185. %files{"resources/$_.key()"} = $_.value for %resources.pairs;
  186. my %meta6 = %(
  187. name => $dist.?name,
  188. ver => $dist.?ver // $dist.?version,
  189. auth => $dist.?auth // $dist.?authority,
  190. provides => %sources,
  191. files => %files,
  192. );
  193. return samewith(Distribution::Hash.new(%meta6, :prefix($*CWD)), :$force);
  194. }
  195. multi method install(Distribution $distribution, Bool :$force) {
  196. my $dist = CompUnit::Repository::Distribution.new($distribution);
  197. my %files = $dist.meta<files>.grep(*.defined).map: -> $link {
  198. $link ~~ Str ?? ($link => $link) !! ($link.keys[0] => $link.values[0])
  199. }
  200. $!lock.protect( {
  201. my @*MODULES;
  202. my $path = self!writeable-path or die "No writeable path found, $.prefix not writeable";
  203. my $lock = $.prefix.child('repo.lock').open(:create, :w);
  204. $lock.lock(2);
  205. my $version = self!repository-version;
  206. self.upgrade-repository unless $version == 2;
  207. my $dist-id = $dist.id;
  208. my $dist-dir = self!dist-dir;
  209. if not $force and $dist-dir.child($dist-id) ~~ :e {
  210. $lock.unlock;
  211. fail "$dist already installed";
  212. }
  213. my $sources-dir = self!sources-dir;
  214. my $resources-dir = self!resources-dir;
  215. my $bin-dir = self!bin-dir;
  216. my $is-win = Rakudo::Internals.IS-WIN;
  217. self!add-short-name($dist.meta<name>, $dist); # so scripts can find their dist
  218. my %links; # map name-path to new content address
  219. my %provides; # meta data gets added, but the format needs to change to
  220. # only extend the structure, not change it
  221. # the following 3 `for` loops should be a single loop, but has been
  222. # left this way due to impeding precomp changes
  223. # lib/ source files
  224. for $dist.meta<provides>.kv -> $name, $file is copy {
  225. # $name is "Inline::Perl5" while $file is "lib/Inline/Perl5.pm6"
  226. my $id = self!file-id(~$name, $dist-id);
  227. my $destination = $sources-dir.child($id);
  228. self!add-short-name($name, $dist, $id);
  229. %provides{ $name } = ~$file => {
  230. :file($id),
  231. :time(try $file.IO.modified.Num),
  232. :$!cver
  233. };
  234. note("Installing {$name} for {$dist.meta<name>}") if $verbose and $name ne $dist.meta<name>;
  235. my $handle = $dist.content($file);
  236. my $content = $handle.open.slurp-rest(:bin,:close);
  237. $destination.spurt($content);
  238. $handle.close;
  239. }
  240. # bin/ scripts
  241. for %files.kv -> $name-path, $file is copy {
  242. next unless $name-path.starts-with('bin/');
  243. my $id = self!file-id(~$file, $dist-id);
  244. my $destination = $resources-dir.child($id); # wrappers are put in bin/; originals in resources/
  245. my $withoutext = $name-path.subst(/\.[exe|bat]$/, '');
  246. for '', '-j', '-m' -> $be {
  247. $.prefix.child("$withoutext$be").IO.spurt:
  248. $perl_wrapper.subst('#name#', $name-path.IO.basename, :g).subst('#perl#', "perl6$be").subst('#dist-name#', $dist.meta<name>);
  249. if $is-win {
  250. $.prefix.child("$withoutext$be.bat").IO.spurt:
  251. $windows_wrapper.subst('#perl#', "perl6$be", :g);
  252. }
  253. else {
  254. $.prefix.child("$withoutext$be").IO.chmod(0o755);
  255. }
  256. }
  257. self!add-short-name($name-path, $dist);
  258. %links{$name-path} = $id;
  259. my $handle = $dist.content($file);
  260. my $content = $handle.open.slurp-rest(:bin,:close);
  261. $destination.spurt($content);
  262. $handle.close;
  263. }
  264. # resources/
  265. for %files.kv -> $name-path, $file is copy {
  266. next unless $name-path.starts-with('resources/');
  267. # $name-path is 'resources/libraries/p5helper' while $file is 'resources/libraries/libp5helper.so'
  268. my $id = self!file-id(~$name-path, $dist-id) ~ '.' ~ $file.IO.extension;
  269. my $destination = $resources-dir.child($id);
  270. %links{$name-path} = $id;
  271. my $handle = $dist.content($file);
  272. my $content = $handle.open.slurp-rest(:bin,:close);
  273. $destination.spurt($content);
  274. $handle.close;
  275. }
  276. my %meta = %($dist.meta);
  277. %meta<files> = %links; # add our new name-path => conent-id mapping
  278. %meta<provides> = %provides; # new meta data added to provides
  279. %!dist-metas{$dist-id} = %meta;
  280. $dist-dir.child($dist-id).spurt: Rakudo::Internals::JSON.to-json(%meta);
  281. # reset cached id so it's generated again on next access.
  282. # identity changes with every installation of a dist.
  283. $!id = Any;
  284. {
  285. my $head = $*REPO;
  286. PROCESS::<$REPO> := self; # Precomp files should only depend on downstream repos
  287. my $precomp = $*REPO.precomp-repository;
  288. my $repo-prefix = self!repo-prefix;
  289. my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id);
  290. my %done;
  291. my $compiler-id = CompUnit::PrecompilationId.new($*PERL.compiler.id);
  292. for %provides.kv -> $source-name, $source-meta {
  293. my $id = CompUnit::PrecompilationId.new($source-meta.values[0]<file>);
  294. $precomp.store.delete($compiler-id, $id);
  295. }
  296. for %provides.kv -> $source-name, $source-meta {
  297. my $id = $source-meta.values[0]<file>;
  298. my $source = $sources-dir.child($id);
  299. my $source-file = $repo-prefix ?? $repo-prefix ~ $source.relative($.prefix) !! $source;
  300. if %done{$id} {
  301. note "(Already did $id)" if $verbose;
  302. next;
  303. }
  304. note("Precompiling $id ($source-name)") if $verbose;
  305. $precomp.precompile(
  306. $source.IO,
  307. CompUnit::PrecompilationId.new($id),
  308. :source-name("$source-file ($source-name)"),
  309. );
  310. %done{$id} = 1;
  311. }
  312. PROCESS::<$REPO> := $head;
  313. }
  314. $lock.unlock;
  315. } ) }
  316. method uninstall(Distribution $distribution) {
  317. my $repo-version = self!repository-version;
  318. self.upgrade-repository unless $repo-version == 2;
  319. # xxx: currently needs to be passed in a distribution object that
  320. # has meta<files> pointing at content-ids, so you cannot yet just
  321. # pass in the original meta data and have it discovered and deleted
  322. # (i.e. update resolve to return such a ::Installation::Distribution)
  323. my $dist = CompUnit::Repository::Distribution.new($distribution);
  324. my %provides = $dist.meta<provides>;
  325. my %files = $dist.meta<files>;
  326. my $sources-dir = self.prefix.child('sources');
  327. my $resources-dir = self.prefix.child('resources');
  328. my $bin-dir = self.prefix.child('bin');
  329. my $dist-dir = self.prefix.child('dist');
  330. self!remove-dist-from-short-name-lookup-files($dist);
  331. my sub unlink-if-exists($path) { unlink($path) if $path.IO.e }
  332. # delete special directory files
  333. for %files.kv -> $name-path, $file {
  334. given $name-path {
  335. when /^bin\/(.*)/ {
  336. # wrappers are located in $bin-dir
  337. unlink-if-exists( $bin-dir.child("$0$_") ) for '', '-m', '-j';
  338. # original bin scripts are in $resources-dir
  339. unlink-if-exists( $resources-dir.child($file) )
  340. }
  341. when /^resources\// {
  342. unlink-if-exists( $resources-dir.child($file) )
  343. }
  344. }
  345. }
  346. # delete sources
  347. unlink-if-exists( $sources-dir.child($_) ) for %provides.values.flatmap(*.values.map(*.<file>));
  348. # delete the meta file
  349. unlink( $dist-dir.child($dist.id) )
  350. }
  351. method files($file, :$name!, :$auth, :$ver) {
  352. my @candi;
  353. my $prefix = self.prefix;
  354. my $lookup = $prefix.child('short').child(nqp::sha1($name));
  355. if $lookup.e {
  356. my $repo-version = self!repository-version;
  357. my @dists = $repo-version < 1
  358. ?? $lookup.lines.unique.map({
  359. self!read-dist($_)
  360. })
  361. !! $lookup.dir.map({
  362. my ($ver, $auth, $api) = $_.slurp.split("\n");
  363. (id => $_.basename, ver => Version.new( $ver || 0 ), auth => $auth, api => $api).hash
  364. });
  365. for @dists.grep({$_<auth> ~~ $auth and $_<ver> ~~ $ver}) -> $dist is copy {
  366. $dist = self!read-dist($dist<id>) if $repo-version >= 1;
  367. with $dist<files>{$file} {
  368. my $candi = %$dist;
  369. $candi<files>{$file} = self!resources-dir.child($candi<files>{$file});
  370. @candi.push: $candi;
  371. }
  372. }
  373. }
  374. @candi
  375. }
  376. method !matching-dist(CompUnit::DependencySpecification $spec) {
  377. if $spec.from eq 'Perl6' {
  378. my $repo-version = self!repository-version;
  379. my $lookup = $.prefix.child('short').child(nqp::sha1($spec.short-name));
  380. if $lookup.e {
  381. my @dists = (
  382. $repo-version < 1
  383. ?? $lookup.lines.unique.map({
  384. $_ => self!read-dist($_)
  385. })
  386. !! $lookup.dir.map({
  387. my ($ver, $auth, $api, $source) = $_.slurp.split("\n");
  388. $_.basename => {
  389. ver => Version.new( $ver || 0 ),
  390. auth => $auth,
  391. api => $api,
  392. source => $source || Any,
  393. }
  394. })
  395. ).grep({
  396. $_.value<auth> ~~ $spec.auth-matcher
  397. and $_.value<ver> ~~ $spec.version-matcher
  398. });
  399. for @dists.sort(*.value<ver>).reverse.map(*.kv) -> ($dist-id, $dist) {
  400. return ($dist-id, $dist);
  401. }
  402. }
  403. }
  404. Nil
  405. }
  406. method !lazy-distribution($dist-id) {
  407. class :: does Distribution::Locally {
  408. has $.dist-id;
  409. has $.read-dist;
  410. has $!installed-dist;
  411. method !dist {
  412. $!installed-dist //= InstalledDistribution.new($.read-dist()(), :$.prefix)
  413. }
  414. method meta(--> Hash:D) { self!dist.meta }
  415. method content($content-id --> IO::Handle:D) { self!dist.content($content-id) }
  416. method Str() { self!dist.Str }
  417. }.new(
  418. :$dist-id,
  419. :read-dist(-> { self!read-dist($dist-id) })
  420. :$.prefix,
  421. )
  422. }
  423. method resolve(
  424. CompUnit::DependencySpecification $spec,
  425. --> CompUnit:D)
  426. {
  427. my ($dist-id, $dist) = self!matching-dist($spec);
  428. if $dist-id {
  429. # xxx: replace :distribution with meta6
  430. return CompUnit.new(
  431. :handle(CompUnit::Handle),
  432. :short-name($spec.short-name),
  433. :version($dist<ver>),
  434. :auth($dist<auth> // Str),
  435. :repo(self),
  436. :repo-id($dist<source> // self!read-dist($dist-id)<provides>{$spec.short-name}.values[0]<file>),
  437. :distribution(self!lazy-distribution($dist-id)),
  438. );
  439. }
  440. return self.next-repo.resolve($spec) if self.next-repo;
  441. Nil
  442. }
  443. method !precomp-stores() {
  444. $!precomp-stores //= Array[CompUnit::PrecompilationStore].new(
  445. self.repo-chain.map(*.precomp-store).grep(*.defined)
  446. )
  447. }
  448. method need(
  449. CompUnit::DependencySpecification $spec,
  450. CompUnit::PrecompilationRepository $precomp = self.precomp-repository(),
  451. CompUnit::PrecompilationStore :@precomp-stores = self!precomp-stores(),
  452. --> CompUnit:D)
  453. {
  454. my ($dist-id, $dist) = self!matching-dist($spec);
  455. if $dist-id {
  456. return %!loaded{~$spec} if %!loaded{~$spec}:exists;
  457. my $source-file-name = $dist<source>
  458. // do {
  459. my $provides = self!read-dist($dist-id)<provides>;
  460. X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw
  461. unless $provides{$spec.short-name}:exists;
  462. $provides{$spec.short-name}.values[0]<file>
  463. };
  464. my $loader = $.prefix.child('sources').child($source-file-name);
  465. my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id);
  466. my $id = $loader.basename;
  467. my $repo-prefix = self!repo-prefix;
  468. my $handle = $precomp.try-load(
  469. CompUnit::PrecompilationDependency::File.new(
  470. :id(CompUnit::PrecompilationId.new($id)),
  471. :src($repo-prefix ?? $repo-prefix ~ $loader.relative($.prefix) !! $loader.abspath),
  472. :$spec,
  473. ),
  474. :source($loader),
  475. :@precomp-stores,
  476. );
  477. my $precompiled = defined $handle;
  478. $handle //= CompUnit::Loader.load-source-file($loader);
  479. # xxx: replace :distribution with meta6
  480. my $compunit = CompUnit.new(
  481. :$handle,
  482. :short-name($spec.short-name),
  483. :version($dist<ver>),
  484. :auth($dist<auth> // Str),
  485. :repo(self),
  486. :repo-id($id),
  487. :$precompiled,
  488. :distribution(self!lazy-distribution($dist-id)),
  489. );
  490. return %!loaded{~$spec} = $compunit;
  491. }
  492. return self.next-repo.need($spec, $precomp, :@precomp-stores) if self.next-repo;
  493. X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw;
  494. }
  495. method resource($dist-id, $key) {
  496. my $dist = %!dist-metas{$dist-id} //= Rakudo::Internals::JSON.from-json(self!dist-dir.child($dist-id).slurp);
  497. # need to strip the leading resources/ on old repositories
  498. self!resources-dir.child($dist<files>{$key.substr(self!repository-version < 2 ?? 10 !! 0)})
  499. }
  500. method id() {
  501. return $!id if $!id;
  502. my $name = self.path-spec;
  503. $name ~= ',' ~ self.next-repo.id if self.next-repo;
  504. my $dist-dir = $.prefix.child('dist');
  505. $!id = nqp::sha1(nqp::sha1($name) ~ ($dist-dir.e ?? $dist-dir.dir !! ''))
  506. }
  507. method short-id() { 'inst' }
  508. method loaded(--> Iterable:D) {
  509. return %!loaded.values;
  510. }
  511. method distribution($id) {
  512. InstalledDistribution.new(self!read-dist($id), :prefix(self.prefix))
  513. }
  514. method installed(--> Iterable:D) {
  515. my $dist-dir = self.prefix.child('dist');
  516. $dist-dir.e
  517. ?? $dist-dir.dir.map({ self.distribution($_.basename) })
  518. !! Nil
  519. }
  520. method precomp-store(--> CompUnit::PrecompilationStore:D) {
  521. $!precomp-store //= CompUnit::PrecompilationStore::File.new(
  522. :prefix(self.prefix.child('precomp')),
  523. )
  524. }
  525. method precomp-repository(--> CompUnit::PrecompilationRepository:D) {
  526. $!precomp := CompUnit::PrecompilationRepository::Default.new(
  527. :store(self.precomp-store),
  528. ) unless $!precomp;
  529. $!precomp
  530. }
  531. sub provides-warning($is-win, $name --> Nil) {
  532. my ($red,$clear) = Rakudo::Internals.error-rcgye;
  533. note "$red==={$clear}WARNING!$red===$clear
  534. The distribution $name does not seem to have a \"provides\" section in its META.info file,
  535. and so the packages will not be installed in the correct location.
  536. Please ask the author to add a \"provides\" section, mapping every exposed namespace to a
  537. file location in the distribution.
  538. See http://design.perl6.org/S22.html#provides for more information.\n";
  539. }
  540. }