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