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 unless $version cmp $vfrom === More;
  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. if $up ~~ Whatever {
  58. $index = $bt.next-interesting-index($index, :noproto);
  59. }
  60. else {
  61. $index = $bt.next-interesting-index($index, :noproto, :setting)
  62. for ^$up;
  63. }
  64. my $callsite = $bt[$index];
  65. # get object, existing or new
  66. my $dep = $what
  67. ?? Deprecation.new(
  68. :name($what),
  69. :$alternative,
  70. :from($vfrom),
  71. :removed($vremoved) )
  72. !! Deprecation.new(
  73. file => $deprecated.file,
  74. type => $deprecated.subtype.tc,
  75. package => try { $deprecated.package.^name } // 'unknown',
  76. name => $deprecated.subname,
  77. :$alternative,
  78. :from($vfrom),
  79. :removed($vremoved),
  80. );
  81. $dep = %DEPRECATIONS{$dep.WHICH} //= $dep;
  82. state $fatal = %*ENV<RAKUDO_DEPRECATIONS_FATAL>;
  83. die $dep.report if $fatal;
  84. # update callsite
  85. $dep.callsites{$file // $callsite.file.IO}{$line // $callsite.line}++;
  86. }
  87. END {
  88. unless %*ENV<RAKUDO_NO_DEPRECATIONS> {
  89. if Deprecation.report -> $message {
  90. note $message; # q:to/TEXT/ doesn't work in settings
  91. note 'Please contact the author to have these occurrences of deprecated code
  92. adapted, so that this message will disappear!';
  93. }
  94. }
  95. }