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. if $.from or $.removed {
  35. $message ~= $.from
  36. ?? "Deprecated since v$.from, will be removed"
  37. !! "Will be removed";
  38. $message ~= $.removed
  39. ?? " with release v$.removed!\n"
  40. !! " sometime in the future\n";
  41. }
  42. }
  43. $message ~= "Please use $.alternative instead.\n";
  44. $message;
  45. }
  46. }
  47. sub DEPRECATED($alternative,$from?,$removed?,:$up = 1,:$what,:$file,:$line,Bool :$lang-vers) {
  48. state $ver = $*PERL.compiler.version;
  49. my $version = $lang-vers ?? nqp::getcomp('perl6').language_version !! $ver;
  50. # if $lang-vers was given, treat the provided versions as language
  51. # versions, rather than compiler versions. Note that we can't
  52. # `state` the lang version (I think) because different CompUnits
  53. # might be using different versions.
  54. my Version $vfrom;
  55. my Version $vremoved;
  56. $from && nqp::iseq_i($version cmp ($vfrom = Version.new: $from), -1)
  57. && return; # not deprecated yet;
  58. $vremoved = Version.new($removed) if $removed;
  59. my $bt = Backtrace.new;
  60. my $deprecated =
  61. $bt[ my $index = $bt.next-interesting-index(2, :named, :setting) ];
  62. if $up ~~ Whatever {
  63. $index = $_ with $bt.next-interesting-index($index, :noproto);
  64. }
  65. else {
  66. $index = $_
  67. with $bt.next-interesting-index($index, :noproto, :setting)
  68. for ^$up;
  69. }
  70. my $callsite = $bt[$index];
  71. # get object, existing or new
  72. my $dep = $what
  73. ?? Deprecation.new(
  74. :name($what),
  75. :$alternative,
  76. :from($vfrom),
  77. :removed($vremoved) )
  78. !! Deprecation.new(
  79. file => $deprecated.file,
  80. type => $deprecated.subtype.tc,
  81. package => try { $deprecated.package.^name } // 'unknown',
  82. name => $deprecated.subname,
  83. :$alternative,
  84. :from($vfrom),
  85. :removed($vremoved),
  86. );
  87. $dep = %DEPRECATIONS{$dep.WHICH} //= $dep;
  88. state $fatal = %*ENV<RAKUDO_DEPRECATIONS_FATAL>;
  89. die $dep.report if $fatal;
  90. # update callsite
  91. ++$dep.callsites{$file // $callsite.file.IO}{$line // $callsite.line};
  92. }
  93. END {
  94. unless %*ENV<RAKUDO_NO_DEPRECATIONS> {
  95. if Deprecation.report -> $message {
  96. note $message; # q:to/TEXT/ doesn't work in settings
  97. note 'Please contact the author to have these occurrences of deprecated code
  98. adapted, so that this message will disappear!';
  99. }
  100. }
  101. }