1: # deprecated - pragmatic module to mark a package or a sub as unsupported
   2: 
   3: package deprecated;
   4: 
   5: =head1 NAME
   6: 
   7: deprecated - pragmatic module to mark a package or a sub as unsupported
   8: 
   9: =head1 SYNOPSIS
  10: 
  11:     package OldeCrufte;
  12:     use deprecated qw(do_hack);  # calling OldeCrufte::do_hack() will carp
  13: 
  14:     package OldeCrufte;
  15:     use deprecated;              # using the OldeCrufte module will carp
  16: 
  17: =head1 DESCRIPTION
  18: 
  19: The word 'deprecated' is used to describe something that has lost support
  20: or is otherwise not recommended.  In programming, this usually means that
  21: a newer, faster, safer or more supportable method has replaced an earlier
  22: routine.
  23: 
  24: When added to a package, this pragma will mark the package, or select
  25: subs within it, as being deprecated.  It does not change the behavior of
  26: the subs within the package, except that on the first call of the sub, a
  27: helpful message is printed to the C<STDERR> stream before running.
  28: 
  29: The runtime messages are suppressed if the PERLLIB environment variable
  30: does not contain the words 'home', 'devel', or 'test'.
  31: This way, only developers see these messages when working with
  32: the programs, but normal end-users do not see them.  This
  33: test is easy to customize for other company library
  34: situations.
  35: 
  36: =cut
  37: 
  38: use strict;
  39: 
  40: sub debug
  41: {
  42:     return (defined $ENV{PERLLIB} and
  43: 	    $ENV{PERLLIB} =~ /home|devel|test/i);
  44: }
  45: 
  46: use constant EVAL_CODE => <<'END_CODE';
  47: sub %s::INIT
  48: {
  49:     my $overridden = \&%s;
  50:     *%s =
  51: 	sub
  52: 	{
  53: 	    if (deprecated::debug())
  54: 	    {
  55: 		require Carp;
  56: 		Carp::carp('%s() is deprecated; ' .
  57: 			   'see the documentation for an alternative;');
  58: 	    }
  59: 	    *%s = $overridden;
  60: 	    goto &$overridden;
  61: 	};
  62: }
  63: END_CODE
  64: 
  65: sub import {
  66:     my $class = shift;
  67:     my $pkg = caller;
  68:     if (not @_ and debug())
  69:     {
  70: 	require Carp;
  71: 	Carp::carp("Module $pkg is deprecated; " .
  72: 		   'see the documentation for an alternative;');
  73:     }
  74:     eval join('', map { sprintf(EVAL_CODE, $pkg, ("$pkg\::$_") x 4) } @_);
  75: }
  76: 
  77: 1;
  78: 
  79: __END__
  80: 
  81: =head1 AUTHORS
  82: 
  83: Proposed and tested by Ed Halley <F<ed@halley.cc>>, and draft
  84: implementation by 'Aristotle', as posted on F<http://www.perlmonks.org/>
  85: in 2003.
  86: 
  87: =cut