1. my %DEPRECATIONS; # where we keep our deprecation info
  2. class Deprecation {
  3. has $.file; # file of the code that is deprecated
  4. has $.type; # type of code (sub/method etc.) that is deprecated
  5. has $.package; # package of code that is deprecated
  6. has $.name; # name of code that is deprecated
  7. has $.alternative; # alternative for code that is deprecated
  8. has %.callsites; # places where called (file -> line -> count)
  9. has Version $.from; # release version from which deprecated
  10. has Version $.removed; # release version when will be removed
  11. multi method WHICH (Deprecation:D:) {
  12. ($!file||"",$!type||"",$!package||"",$!name).join(':');
  13. }
  14. proto method report (|) { * }
  15. multi method report (Deprecation:U:) {
  16. return Nil unless %DEPRECATIONS;
  17. my $message = "Saw {+%DEPRECATIONS} occurrence{ 's' if +%DEPRECATIONS != 1 } of deprecated code.\n";
  18. $message ~= ("=" x 80) ~ "\n";
  19. for %DEPRECATIONS.sort(*.key)>>.value>>.report -> $r {
  20. $message ~= $r;
  21. $message ~= ("-" x 80) ~ "\n";
  22. }
  23. %DEPRECATIONS = (); # reset for new batches if applicable
  24. $message.chop;
  25. }
  26. multi method report (Deprecation:D:) {
  27. my $type = $.type ?? "$.type " !! "";
  28. my $name = $.name ?? "$.name " !! "";
  29. my $package = $.package ?? "(from $.package) " !! "";
  30. my $message = $type ~ $name ~ $package ~ "seen at:\n";
  31. for %.callsites.kv -> $file, $lines {
  32. $message ~=
  33. " $file, line{ 's' if +$lines > 1 } {$lines.keys.sort.join(',')}\n";
  34. $message ~=
  35. "Deprecated since v$.from, will be removed {$.removed
  36. ?? 'with release v' ~ $.removed ~ '!'
  37. !! 'sometime in the future'
  38. }\n" if $.from;
  39. }
  40. $message ~= "Please use $.alternative instead.\n";
  41. $message;
  42. }
  43. }
  44. sub DEPRECATED($alternative,$from?,$removed?,:$up = 1,:$what,:$file,:$line) {
  45. # not deprecated yet
  46. state $version = $*PERL.compiler.version;
  47. my Version $vfrom;
  48. my Version $vremoved;
  49. if $from {
  50. $vfrom = Version.new($from);
  51. return if ($version cmp $vfrom) ~~ Less | Same; # can be better?
  52. }
  53. $vremoved = Version.new($removed) if $removed;
  54. my $bt = Backtrace.new;
  55. my $deprecated =
  56. $bt[ my $index = $bt.next-interesting-index(2, :named, :setting) ];
  57. $index = $bt.next-interesting-index($index, :noproto, :setting) for ^$up;
  58. my $callsite = $bt[$index];
  59. # get object, existing or new
  60. my $dep = $what
  61. ?? Deprecation.new(
  62. :name($what),
  63. :$alternative,
  64. :from($vfrom),
  65. :removed($vremoved) )
  66. !! Deprecation.new(
  67. file => $deprecated.file,
  68. type => $deprecated.subtype.tc,
  69. package => try { $deprecated.package.^name } // 'unknown',
  70. name => $deprecated.subname,
  71. :$alternative,
  72. :from($vfrom),
  73. :removed($vremoved),
  74. );
  75. $dep = %DEPRECATIONS{$dep.WHICH} //= $dep;
  76. state $fatal = %*ENV<RAKUDO_DEPRECATIONS_FATAL>;
  77. die $dep.report if $fatal;
  78. # update callsite
  79. $dep.callsites{$file // $callsite.file.IO}{$line // $callsite.line}++;
  80. }
  81. END {
  82. unless %*ENV<RAKUDO_NO_DEPRECATIONS> {
  83. if Deprecation.report -> $message {
  84. note $message; # q:to/TEXT/ doesn't work in settings
  85. note 'Please contact the author to have these occurrences of deprecated code
  86. adapted, so that this message will disappear!';
  87. }
  88. }
  89. }