lib/Sub/Private.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (16/16)
Approximate LCSAJ segments: 49

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package Sub::Private;
    2: 
    3: # Minimum Perl version: 5.14 (${^GLOBAL_PHASE}, needed to protect subs in
    4: # packages loaded after CHECK)
    5: use 5.014;
    6: use strict;
    7: use warnings;
    8: 
    9: use Attribute::Handlers;
   10: use B::Hooks::EndOfScope qw();
   11: use Carp              qw(croak carp);
   12: use Readonly;
   13: use Params::Validate::Strict 0.33 qw(validate_strict);
   14: use Return::Set       qw(set_return);
   15: use Sub::Identify     qw(get_code_info);
   16: 
   17: # namespace::clean is used as a class method only; import nothing.
   18: use namespace::clean qw();
   19: 
   20: =head1 NAME
   21: 
   22: Sub::Private - Private subroutines and methods
   23: 
   24: =head1 VERSION
   25: 
   26: Version 0.07
   27: 
   28: =cut
   29: 
   30: our $VERSION = '0.07';
   31: 
   32: # ---------------------------------------------------------------------------
   33: # Mode-name constants.  Using Readonly prevents accidental overwriting.
   34: # ---------------------------------------------------------------------------
   35: 
   36: Readonly::Scalar my $MODE_NAMESPACE => 'namespace';
   37: Readonly::Scalar my $MODE_ENFORCE   => 'enforce';
   38: 
   39: # Config-key constants -- avoids bare magic strings in %config lookups.
   40: Readonly::Scalar my $KEY_MODE           => 'mode';
   41: Readonly::Scalar my $KEY_HARNESS_BYPASS => 'harness_bypass';
   42: 
   43: # The phase name the attribute handler passes to itself when it finishes,
   44: # at the end of the enclosing scope, a sub compiled after CHECK.
   45: Readonly::Scalar my $PHASE_SCOPE_END => 'SCOPE_END';
   46: 
   47: # Self-referential constant: the canonical name of this package.
   48: Readonly::Scalar my $SELF => __PACKAGE__;
   49: 
   50: # Validation schema for a single Perl sub name passed to import().
   51: Readonly::Scalar my $SUB_NAME_SCHEMA => {
   52: 	name => {
   53: 		type  => 'string',
   54: 		regex => qr/\A[_a-zA-Z]\w*\z/,
   55: 	}
   56: };
   57: 
   58: =head1 SYNOPSIS
   59: 
   60:     package Foo;
   61:     use Sub::Private;
   62: 
   63:     sub foo { return 42 }
   64: 
   65:     sub bar :Private {
   66:         return foo() + 1;
   67:     }
   68: 
   69:     sub baz {
   70:         return bar() + 1;
   71:     }
   72: 
   73: =head1 DESCRIPTION
   74: 
   75: Enforces strictly private access on subroutines.  A subroutine decorated
   76: with C<:Private> (or named in C<use Sub::Private qw(...)> when in enforce
   77: mode) may only be called from within its defining package.  Subclasses do
   78: not inherit access: private means I<this package only>.
   79: 
   80: =head2 Two enforcement modes
   81: 
   82: =over 4
   83: 
   84: =item C<namespace> mode (default, backward-compatible)
   85: 
   86: Removes the subroutine from the package symbol table using
   87: L<namespace::clean>.  Direct (non-method) function calls compiled before
   88: cleanup still work because Perl optimises them to direct opcode references.
   89: OO method dispatch (C<$self->name>) does not work for private subs in this
   90: mode because method lookup uses the symbol table at runtime.
   91: 
   92: This is the default mode and is backward-compatible with all existing code.
   93: 
   94: =item C<enforce> mode (OO-safe, opt-in)
   95: 
   96: Replaces the subroutine with a wrapper closure that checks C<caller> at
   97: call time and either delegates (owner package) or croaks (anyone else).
   98: Works correctly with OO dispatch (C<$self->_helper>).
   99: 
  100: Enable it for your package only, in the C<use> line:
  101: 
  102:     package MyClass;
  103:     use Sub::Private { mode => 'enforce' };
  104:     sub _helper :Private { ... }
  105: 
  106: This is the recommended form for modules.  Other packages keep the mode
  107: they chose, or the global C<$Sub::Private::config{mode}>.
  108: 
  109: The older form sets the mode for every package in the program, and must
  110: stay set until C<CHECK>, so it changes how other modules' C<:Private>
  111: subs are handled.  Use it only in a program, not in a module:
  112: 
  113:     BEGIN { $Sub::Private::config{mode} = 'enforce' }
  114:     package MyClass;
  115:     use Sub::Private;
  116:     sub _helper :Private { ... }
  117: 
  118: =back
  119: 
  120: =head2 Behaviour of wrapped subs (enforce mode)
  121: 
  122: =over 4
  123: 
  124: =item * The wrapper hands over with C<goto &sub>, so it does not appear
  125: on the call stack: C<caller> inside a private sub sees its real caller.
  126: 
  127: =item * Arguments, C<@_> aliasing and calling context (list, scalar or
  128: void) are passed through unchanged.
  129: 
  130: =item * C<$_> is left untouched, whether the call is allowed or blocked.
  131: 
  132: =item * A blocked call croaks; it does not fall through to C<AUTOLOAD>.
  133: 
  134: =item * Works with L<Moo> and L<Moose> classes; use the declarative form
  135: after C<use Moo> or C<use Moose>.
  136: 
  137: =back
  138: 
  139: =head2 Loading at run time
  140: 
  141: Packages that use C<Sub::Private> may be loaded at run time (C<require>,
  142: a plugin loader, a string C<eval>), and C<Sub::Private> itself may be
  143: loaded for the first time that way.  The private subs are then wrapped
  144: (or removed, in C<namespace> mode) when the enclosing scope, normally the
  145: rest of the file, has been compiled.
  146: 
  147: =head2 Bypass for testing
  148: 
  149: Either condition alone (OR logic) disables all access checks in enforce
  150: mode:
  151: 
  152: =over 4
  153: 
  154: =item * C<$Sub::Private::BYPASS> set to a true value.  Use C<local> in
  155: tests.
  156: 
  157: =item * C<$ENV{HARNESS_ACTIVE}> set (the convention used by
  158: L<Test::Harness>/prove).
  159: 
  160: =back
  161: 
  162: C<$Sub::Private::BYPASS> is the recommended form for new test code.
  163: The C<HARNESS_ACTIVE> bypass can be disabled:
  164: 
  165:     $Sub::Private::config{harness_bypass} = 0;
  166: 
  167: =head2 Configuration

  Mutants (Total: 1, Killed: 1, Survived: 0)
  168: 
  169:     use Sub::Private { mode => 'enforce' };  -- this package only (recommended)
  170:     $Sub::Private::config{mode}            -- 'namespace' (default) or 'enforce',
  171:                                               for packages that chose no mode
  172:     $Sub::Private::config{harness_bypass}  -- 1 (default); set to 0 to test enforcement
  173: 
  174: =head2 Error message format (enforce mode)
  175: 
  176:     bar() is a private subroutine of Foo and cannot be called from Bar
  177: 
  178: =cut
  179: 
  180: # Public bypass flag.  Use C<local $Sub::Private::BYPASS = 1> in test code.
  181: our $BYPASS = 0;
  182: 
  183: # Module configuration.  //= preserves any value a caller set in a BEGIN
  184: # block before this module body runs.
  185: our %config;
  186: $config{$KEY_MODE}           //= $MODE_NAMESPACE;
  187: $config{$KEY_HARNESS_BYPASS} //= 1;

  Mutants (Total: 1, Killed: 1, Survived: 0)
  188: 
  189: # Pending (owner_pkg, sub_name) pairs to be wrapped at CHECK time.
  190: # Populated by import(); consumed and cleared by the CHECK block.
  191: my @_pending;
  192: 
  193: # Modes chosen per package with "use Sub::Private { mode => ... }", keyed by
  194: # package name.  A package not listed uses $config{mode}.
  195: my %_package_mode;
  196: 
  197: # True once CHECK has run, so wrapping must happen without it.  Set by our
  198: # own CHECK block, or here when this module is first loaded after CHECK
  199: # (run-time require, plugin loader, string eval).
  200: my $_post_check = (${^GLOBAL_PHASE} ne 'START') ? 1 : 0;
  201: 
  202: # -------------------------------------------------------------------
  203: # ATTRIBUTE HANDLER
  204: # -------------------------------------------------------------------
  205: 
  206: # Install :Private in UNIVERSAL so every package can use it after a
  207: # single "use Sub::Private", with no per-package setup required.
  208: # ATTR(CODE,CHECK) fires at CHECK time, after all subs are compiled.
  209: # The BEGIN phase covers code compiled after CHECK, when the CHECK-phase
  210: # call never comes.
  211: sub UNIVERSAL::Private :ATTR(CODE,BEGIN,CHECK) {
●212 → 214 → 235●212 → 214 → 0  212: 	my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
  213: 
  214: 	if ($phase eq 'BEGIN') {
  215: 		# Before CHECK, the CHECK-phase call does the work.
  216: 		return unless $_post_check;
  217: 
  218: 		# After CHECK the sub is still being compiled and may have no name
  219: 		# yet, so finish the job when the enclosing scope is compiled.
  220: 		# on_scope_end works here because the user's code is compiling.
  221: 		B::Hooks::EndOfScope::on_scope_end(sub {
  222: 			my ($pkg, $name) = get_code_info($referent);
  223: 			no strict 'refs';	## no critic (ProhibitNoStrict)
  224: 			UNIVERSAL::Private($pkg, \*{"${pkg}::$name"}, $referent, $attr, $data, $PHASE_SCOPE_END);
  225: 		});
  226: 		return;
  227: 	}
  228: 
  229: 	# Once its own CHECK block has run, Attribute::Handlers also makes the
  230: 	# CHECK-phase call straight away for code compiled later, before the sub
  231: 	# is named or installed ($symbol is then 'ANON').  Acting on it removed
  232: 	# the half-compiled sub in namespace mode, and installed a wrapper as
  233: 	# main::ANON in enforce mode.  The BEGIN-phase call above deals with
  234: 	# that code, so only the real CHECK phase is used here.
●235 → 245 → 255●235 → 245 → 0  235: 	return if $phase eq 'CHECK' && ${^GLOBAL_PHASE} ne 'CHECK';
  236: 
  237: 	my $sub_name = *{$symbol}{NAME};
  238: 
  239: 	# The mode chosen by the sub's own package, or else the global one.
  240: 	my $mode = _mode_for($package);
  241: 
  242: 	# Reject unrecognised mode values early rather than silently misbehaving.
  243: 	_assert_known_mode($mode);
  244: 
  245: 	if ($mode eq $MODE_ENFORCE) {
  246: 		# Enforce mode: replace the stash entry with an access-checking wrapper.
  247: 		no warnings 'redefine';
  248: 		*{$symbol} = _wrap($package, $sub_name, $referent);
  249: 	} else {
  250: 		# Namespace mode: remove the sub from the stash entirely.
  251: 		# on_scope_end does NOT work from a CHECK-phase callback, so we call
  252: 		# clean_subroutines() directly here.
  253: 		namespace::clean->clean_subroutines( get_code_info($referent) );
  254: 	}
●255 → 255 → 0  255: 	return;
  256: }
  257: 
  258: # -------------------------------------------------------------------
  259: # PUBLIC INTERFACE
  260: # -------------------------------------------------------------------
  261: 
  262: =head1 PUBLIC INTERFACE
  263: 
  264: =head2 import
  265: 
  266:     use Sub::Private;                    # attribute form -- no arguments
  267:     use Sub::Private qw(_a _b _c);      # declarative form (enforce mode only)
  268:     use Sub::Private { mode => 'enforce' };              # mode for this package
  269:     use Sub::Private { mode => 'enforce' }, qw(_a _b);   # both
  270: 
  271: =head3 Purpose
  272: 
  273: Called automatically by C<use Sub::Private>.
  274: 
  275: With B<no arguments>: makes the C<:Private> attribute globally available
  276: via C<UNIVERSAL>.  No other action is taken.
  277: 
  278: With B<a hash reference first>: sets options for the calling package
  279: only.  The one option is C<mode>, C<'namespace'> or C<'enforce'>.  It
  280: decides what happens to that package's C<:Private> subs and whether it
  281: may use the declarative form, whatever C<$Sub::Private::config{mode}>
  282: says.  The global mode is not changed, so other packages are not
  283: affected.  The mode applies to subs in the package that made the C<use>
  284: call, so put the C<use> line inside the package.
  285: 
  286: With B<one or more sub names>: registers those named subs in the calling
  287: package for access-enforcement wrapping at C<CHECK> time.  If C<CHECK>
  288: has already fired (for example the package is loaded with C<require> at
  289: run time), the subs are wrapped as soon as the enclosing scope (normally
  290: the rest of the file) has been compiled, so the C<use> line can still
  291: come before the subs it names.  A direct C<< Sub::Private->import(...) >>
  292: call at run time wraps immediately.  Requires the package's mode (see
  293: above), or else C<$Sub::Private::config{mode}>, to equal C<'enforce'>;
  294: croaks otherwise.
  295: 
  296: =head3 Arguments
  297: 
  298: =over 4
  299: 
  300: =item C<\%options> (optional)
  301: 
  302: A hash reference, before any sub names.  The only key allowed is
  303: C<mode>, whose value must be C<'namespace'> or C<'enforce'>.
  304: 
  305: =item C<@subs> (optional)
  306: 
  307: Zero or more Perl sub names.  Each must be a defined, non-reference scalar
  308: matching C</\A[_a-zA-Z]\w*\z/>.  C<undef>, references, empty strings, and
  309: names starting with a digit or containing hyphens are all rejected.
  310: 
  311: =back
  312: 
  313: =head3 Returns
  314: 
  315: The class name (C<'Sub::Private'>) as a plain string in all cases.
  316: 
  317: =head3 Side effects
  318: 
  319: =over 4
  320: 
  321: =item * With C<\%options>: records the mode for the calling package.  A
  322: later call from the same package replaces it.
  323: 
  324: =item * Pre-CHECK: appends C<[$owner_pkg, $sub_name]> pairs to the
  325: internal C<@_pending> list.
  326: 
  327: =item * Post-CHECK, during compilation: installs wrapper closures in the
  328: calling package's stash when the enclosing scope has been compiled.
  329: 
  330: =item * Post-CHECK, at run time: installs wrapper closures directly in the
  331: calling package's stash.
  332: 
  333: =back
  334: 
  335: =head3 Example
  336: 
  337:     BEGIN { $Sub::Private::config{mode} = 'enforce' }
  338:     package MyClass;

  Mutants (Total: 1, Killed: 1, Survived: 0)
  339:     use Sub::Private qw(_helper _init);

  Mutants (Total: 1, Killed: 1, Survived: 0)
  340: 
  341:     sub new     { bless {}, shift }
  342:     sub _helper { ... }    # wrapped at CHECK time
  343:     sub _init   { ... }    # wrapped at CHECK time
  344:     sub run     { my $s = shift; $s->_helper; $s->_init }
  345: 
  346: Enforce mode for one package, leaving every other package alone:
  347: 
  348:     package MyClass;
  349:     use Sub::Private { mode => 'enforce' };
  350: 
  351:     sub new        { bless {}, shift }
  352:     sub _helper :Private { ... }    # wrapped at CHECK time
  353:     sub run        { (shift)->_helper }
  354: 
  355: =head3 API SPECIFICATION
  356: 
  357: =head4 Input
  358: 
  359:     # No-argument form: always valid.
  360:     Sub::Private->import();
  361: 
  362:     # Options, first in the list (optional):
  363:     {
  364:         options => {
  365:             type     => 'hashref',
  366:             optional => 1,
  367:             schema   => {
  368:                 mode => {
  369:                     type     => 'string',
  370:                     memberof => [ 'namespace', 'enforce' ],
  371:                     optional => 1,
  372:                 },
  373:             },
  374:         }
  375:     }
  376: 
  377:     # Declarative form (enforce mode only):
  378:     {
  379:         subs => {
  380:             type     => 'array',
  381:             optional => 1,
  382:             element  => {
  383:                 type  => 'string',
  384:                 regex => qr/\A[_a-zA-Z]\w*\z/,
  385:             },
  386:         }
  387:     }
  388: 
  389: =head4 Output
  390: 
  391:     { type => 'string' }    # returns the class name 'Sub::Private'
  392: 
  393: =head3 MESSAGES
  394: 
  395:     Message                                              Meaning / Action
  396:     ---------------------------------------------------  -----------------------------------------------
  397:     "Sub::Private->import: declarative form requires     use Sub::Private qw(...) was called while
  398:      mode => 'enforce'"                                  the package's mode is not 'enforce'.  Use
  399:                                                          use Sub::Private { mode => 'enforce' },
  400:                                                          qw(...) instead.
  401: 
  402:     "Sub::Private->import: unknown option 'KEY'"         The options hash has a key other than mode.
  403: 
  404:     "Sub::Private: unknown mode 'MODE' -- use            The mode option, or $config{mode}, is not
  405:      'namespace' or 'enforce'"                           one of the two modes.
  406: 
  407:     "Sub::Private->import: 'NAME' is not a valid         The sub name failed the identifier regex.
  408:      Perl identifier"                                    Check for typos, hyphens, leading digits,
  409:                                                          undef, or reference values in the import list.
  410: 
  411:     "Sub::Private: PKG::NAME is not defined"             The named sub was not found in the stash at
  412:                                                          wrap time.  Define the sub before import()
  413:                                                          runs, before CHECK fires, or (after CHECK)
  414:                                                          before the end of the enclosing scope.
  415:                                                          After CHECK, the location reported is the
  416:                                                          "use Sub::Private" line.
  417: 
  418: =cut
  419: 
  420: sub import {
●421 → 435 → 448●421 → 435 → 0  421: 	my ($class, @subs) = @_;
  422: 	my ($owner_pkg, $file, $line) = caller;
  423: 
  424: 	# A leading hashref holds options for the calling package only.
  425: 	_set_package_options($owner_pkg, shift @subs) if ref($subs[0]) eq 'HASH';
  426: 
  427: 	# No sub names: the :Private attribute is always available via UNIVERSAL.
  428: 	return set_return($class, { type => 'string' }) unless @subs;
  429: 
  430: 	# Declarative form is only meaningful in enforce mode.
  431: 	croak "$SELF->import: declarative form requires mode => '$MODE_ENFORCE'"
  432: 		if _mode_for($owner_pkg) ne $MODE_ENFORCE;
  433: 
  434: 	# Validate every name before touching the stash (fail-fast, all-or-nothing).
  435: 	for my $sub_name (@subs) {
  436: 		# Coerce invalid types (undef, ref) to empty string before schema check.
  437: 		my $check = (defined $sub_name && !ref $sub_name) ? $sub_name : q{};
  438: 		eval {
  439: 			validate_strict(
  440: 				schema => $SUB_NAME_SCHEMA,
  441: 				input  => { name => $check },
  442: 			);
  443: 		};
  444: 		croak "$SELF->import: '$check' is not a valid Perl identifier" if $@;
  445: 	}
  446: 
  447: 	# Schedule or immediately apply wrapping depending on compile phase.
●448 → 448 → 468●448 → 448 → 0  448: 	if ($_post_check) {
  449: 		if (defined $^S) {
  450: 			# Called at run time: the subs already exist, wrap them now.
  451: 			_process_one($owner_pkg, $_) for @subs;
  452: 		} else {
  453: 			# "use" after CHECK (e.g. a run-time require): the subs below the
  454: 			# "use" line are not compiled yet, so wrap them when the
  455: 			# enclosing scope has been compiled.
  456: 			B::Hooks::EndOfScope::on_scope_end(sub {
  457: 				# Report errors at the "use" line, not inside the hook.
  458: 				eval { _process_one($owner_pkg, $_) for @subs; 1 } or do {
  459: 					(my $err = $@) =~ s/ at .+? line \d+\.?\n\z//s;
  460: 					die "$err at $file line $line.\n";
  461: 				};
  462: 			});
  463: 		}
  464: 	} else {
  465: 		push @_pending, [ $owner_pkg, $_ ] for @subs;
  466: 	}

  Mutants (Total: 1, Killed: 1, Survived: 0)
  467: 
●468 → 468 → 0  468: 	return set_return($class, { type => 'string' });
  469: }
  470: 
  471: # -------------------------------------------------------------------
  472: # CHECK-TIME PROCESSING
  473: # -------------------------------------------------------------------
  474: 
  475: # Process all declarative wraps queued during import().
  476: # After this fires, $_post_check=1 so future import() calls wrap without it.
  477: # When this module is loaded after CHECK the block cannot run, which is
  478: # expected; silence "Too late to run CHECK block".
  479: {
  480: 	no warnings 'void';
  481: 	CHECK {
  482: 		$_post_check = 1;
  483: 		_process_one(@$_) for @_pending;
  484: 		@_pending = ();
  485: 	}
  486: }
  487: 
  488: # -------------------------------------------------------------------
  489: # PRIVATE SUBROUTINES
  490: # -------------------------------------------------------------------
  491: 
  492: # _assert_known_mode
  493: # Purpose      : Validate that $config{mode} is a recognised string.
  494: # Entry        : $mode -- the value to validate
  495: # Exit status  : Returns normally for 'namespace' or 'enforce'; croaks
  496: #                with a descriptive message for any other value.
  497: sub _assert_known_mode {
  498: 	my ($mode) = @_;
  499: 	return if $mode eq $MODE_NAMESPACE || $mode eq $MODE_ENFORCE;
  500: 	croak "$SELF: unknown mode '$mode'"
  501: 		. " -- use '$MODE_NAMESPACE' or '$MODE_ENFORCE'";
  502: }
  503: 
  504: # _mode_for
  505: # Purpose      : Find the mode that applies to the subs of a package.
  506: # Entry        : $pkg -- a package name
  507: # Exit status  : Returns the mode the package chose with
  508: #                "use Sub::Private { mode => ... }", or else $config{mode}.
  509: # Side effects : None.
  510: sub _mode_for {
  511: 	my ($pkg) = @_;
  512: 
  513: 	return $_package_mode{$pkg} // $config{$KEY_MODE};
  514: }
  515: 
  516: # _set_package_options
  517: # Purpose      : Record the options a package gave in its "use" line.
  518: # Entry        : $pkg     -- the package that called import()
  519: #                $options -- hashref; the only key allowed is "mode"
  520: # Exit status  : Returns normally; croaks on an unknown key or mode.
  521: # Side effects : Sets the package's entry in %_package_mode.  The global
  522: #                $config{mode} is not touched, so other packages are not
  523: #                affected.
  524: sub _set_package_options {
●525 → 528 → 531●525 → 528 → 0  525: 	my ($pkg, $options) = @_;
  526: 
  527: 	# Check every key before changing anything (all-or-nothing).
  528: 	for my $key (sort keys %{$options}) {
  529: 		croak "$SELF->import: unknown option '$key'" if $key ne $KEY_MODE;
  530: 	}
●531 → 531 → 536●531 → 531 → 0  531: 	if (exists $options->{$KEY_MODE}) {
  532: 		my $mode = $options->{$KEY_MODE} // q{};
  533: 		_assert_known_mode($mode);
  534: 		$_package_mode{$pkg} = $mode;
  535: 	}
●536 → 536 → 0  536: 	return;
  537: }
  538: 
  539: # _process_one
  540: # Purpose      : Look up a named sub in a package stash and install a wrapper.
  541: # Entry        : $owner_pkg -- the package that declared the sub
  542: #                $sub_name  -- the unqualified sub name to wrap
  543: # Exit status  : Returns normally; the stash entry is replaced with a wrapper.
  544: # Side effects : Modifies the package stash for $owner_pkg.
  545: # Notes        : Guarded by _assert_private_caller -- external calls croak.
  546: sub _process_one {
  547: 	my ($owner_pkg, $sub_name) = @_;
  548: 
  549: 	# Guard: only Sub::Private itself may call this.
  550: 	_assert_private_caller('_process_one')
  551: 		unless $BYPASS || ($config{$KEY_HARNESS_BYPASS} && $ENV{HARNESS_ACTIVE});
  552: 
  553: 	no strict 'refs';	## no critic (ProhibitNoStrict)
  554: 
  555: 	# Ensure the target sub exists in the stash before wrapping.
  556: 	croak "$SELF: ${owner_pkg}::${sub_name} is not defined"
  557: 		unless defined &{"${owner_pkg}::${sub_name}"};
  558: 
  559: 	my $code = \&{"${owner_pkg}::${sub_name}"};
  560: 
  561: 	# Replace the stash entry with the enforcement wrapper.
  562: 	no warnings 'redefine';
  563: 	*{"${owner_pkg}::${sub_name}"} = _wrap($owner_pkg, $sub_name, $code);
  564: 	return;
  565: }
  566: 
  567: # _wrap
  568: # Purpose      : Build an enforcement wrapper closure around a coderef.
  569: # Entry        : $owner_pkg -- the package that owns the private sub
  570: #                $sub_name  -- the unqualified sub name (for error messages)
  571: #                $code      -- the original coderef to delegate to
  572: # Exit status  : Returns a new coderef that enforces the private-access rule.
  573: # Side effects : none (variables captured by closure)
  574: # Notes        : goto &$code is used rather than $code->(@_) so that caller()
  575: #                inside the private sub sees the real caller, not Sub::Private.
  576: #                This is load-bearing: removing it breaks tests that inspect
  577: #                caller() inside a private sub.  Guarded by _assert_private_caller.
  578: sub _wrap {
  579: 	my ($owner_pkg, $sub_name, $code) = @_;
  580: 
  581: 	# Guard: only Sub::Private itself may call this.
  582: 	_assert_private_caller('_wrap')
  583: 		unless $BYPASS || ($config{$KEY_HARNESS_BYPASS} && $ENV{HARNESS_ACTIVE});
  584: 
  585: 	# Capture the three args in the closure; the wrapper has no mutable state.
  586: 	return sub {
  587: 		Sub::Private::_check_access($owner_pkg, $sub_name);
  588: 		goto &$code;    ## no critic (ControlStructures::ProhibitGoto)
  589: 	};
  590: }
  591: 
  592: # _check_access
  593: # Purpose      : Enforce the private-access invariant at call time.
  594: # Entry        : $owner_pkg -- the package that owns the private sub
  595: #                $sub_name  -- unqualified sub name (for error messages)
  596: # Exit status  : Returns normally if the immediate non-Sub::Private caller is
  597: #                the owner package.  Croaks if any other package is found first.
  598: # Notes        : Unlike Sub::Protected there is NO ->isa check.  Private means
  599: #                the owner package ONLY; subclasses are blocked.
  600: #                The stack walk skips Sub::Private frames so the wrapper is
  601: #                transparent to the check.
  602: sub _check_access {
●603 → 611 → 0  603: 	my ($owner_pkg, $sub_name) = @_;
  604: 
  605: 	# Fast bypass paths: either condition alone disables all checks (OR logic).
  606: 	return if $BYPASS;
  607: 	return if $config{$KEY_HARNESS_BYPASS} && $ENV{HARNESS_ACTIVE};
  608: 
  609: 	# Walk the call stack, skipping Sub::Private wrapper frames.
  610: 	my $frame = 0;
  611: 	while (1) {
  612: 		my $pkg = (caller($frame))[0];
  613: 
  614: 		# Reached the bottom of the stack with no valid caller found.
  615: 		if (!defined $pkg) {
  616: 			croak "${sub_name}() is a private subroutine of ${owner_pkg}"
  617: 				. ' and cannot be called from outside any package';
  618: 		}
  619: 
  620: 		# Skip any Sub::Private frames (e.g., the wrapper closure itself).
  621: 		$frame++, next if $pkg eq $SELF;
  622: 
  623: 		# The first non-Sub::Private caller must be the owner; everyone else
  624: 		# is blocked -- no isa allowance, unlike Sub::Protected.
  625: 		return if $pkg eq $owner_pkg;
  626: 		croak "${sub_name}() is a private subroutine of ${owner_pkg}"
  627: 			. " and cannot be called from ${pkg}";
  628: 	}
  629: }
  630: 
  631: # _assert_private_caller
  632: # Purpose      : Croak if a guarded private method was called from outside
  633: #                Sub::Private.
  634: # Entry        : $method_name -- the guarded method name (for error messages)
  635: # Exit status  : Returns normally if caller(1) is Sub::Private; croaks
  636: #                otherwise with a descriptive message.
  637: # Notes        : caller(1) is the package that called the guarded method,
  638: #                which in turn called this function.
  639: sub _assert_private_caller {
  640: 	my ($method_name) = @_;
  641: 
  642: 	# caller(1): the package one frame above the guarded method.
  643: 	my $caller = (caller(1))[0] // q{};
  644: 
  645: 	# Only calls originating within Sub::Private itself are permitted.
  646: 	return if $caller eq $SELF;
  647: 
  648: 	croak "${method_name}() is a private method of $SELF"
  649: 		. " and cannot be called from ${caller}";
  650: }
  651: 
  652: 1;
  653: 
  654: __END__
  655: 
  656: =head1 PUBLIC VARIABLES
  657: 
  658: =head2 C<$BYPASS>
  659: 
  660: Set to a true value to disable all access checks (enforce mode only).
  661: Use C<local> in tests; see L</Bypass for testing>.
  662: 
  663: =head2 C<%config>
  664: 
  665: Module-level configuration hash.  Supported keys:
  666: 
  667: =over 4
  668: 
  669: =item C<mode>
  670: 
  671: C<'namespace'> (default) or C<'enforce'>.  Must be set in a C<BEGIN>
  672: block before C<use Sub::Private> to take effect at C<CHECK> time.  It
  673: applies to every package that did not choose its own mode with
  674: C<use Sub::Private { mode => ... }>, so a module should use that form
  675: instead of changing this value.
  676: 
  677: =item C<harness_bypass>
  678: 
  679: When true (default), access checks are skipped whenever
  680: C<$ENV{HARNESS_ACTIVE}> is set.  Set to 0 to test enforcement under
  681: C<prove>.
  682: 
  683: =back
  684: 
  685: =head1 KNOWN LIMITATIONS
  686: 
  687: =over 4
  688: 
  689: =item C<namespace> mode: OO dispatch fails for private subs
  690: 
  691: C<$self->_helper> from within the owner package fails because method
  692: dispatch uses the symbol table at runtime, which no longer contains the
  693: entry.  Use C<enforce> mode for OO classes.
  694: 
  695: =item C<enforce> mode: runtime-only
  696: 
  697: Checks are runtime only; there is no compile-time enforcement.
  698: 
  699: =item C<enforce> mode: raw coderef bypass
  700: 
  701: A raw code reference obtained B<before> wrapping (via C<can()> or
  702: C<\&Foo::_helper>) bypasses the check.  The attribute form makes this
  703: hard because wrapping happens at CHECK time.  When the package is loaded
  704: after CHECK, wrapping happens at the end of the enclosing scope, so a
  705: C<BEGIN> block earlier in the same file could still take a reference to
  706: the unwrapped sub.
  707: 
  708: =item C<enforce> mode: C<can()> leaks private method existence
  709: 
  710: In C<enforce> mode the original sub is replaced by a wrapper closure, so
  711: C<< ->can('_helper') >> returns the wrapper (a true value) even to callers outside
  712: the owner package.  In C<namespace> mode the stash entry is deleted entirely,
  713: so C<< ->can >> correctly returns C<undef>.  A future release may inject a
  714: caller-aware C<can()> override into each class that uses C<enforce> mode,
  715: returning the coderef only when the caller is the owner package and C<undef>
  716: for everyone else.
  717: 
  718: =item UNIVERSAL namespace pollution
  719: 
  720: The C<:Private> attribute is installed in C<UNIVERSAL>, which is
  721: intentional (any package can use it after a single C<use>), but it does
  722: introduce C<UNIVERSAL::Private> into the global namespace.
  723: 
  724: =back
  725: 
  726: =head1 DEPENDENCIES
  727: 
  728: Perl 5.14 or later,
  729: L<Carp> (core),
  730: L<Attribute::Handlers> (core),
  731: L<B::Hooks::EndOfScope>,
  732: L<Readonly>,
  733: L<Params::Validate::Strict>,
  734: L<Return::Set>,
  735: L<namespace::clean>,
  736: L<Sub::Identify>.
  737: 
  738: =head1 SEE ALSO
  739: 
  740: =over 4
  741: 
  742: =item * L<Test Dashboard|https://nigelhorne.github.io/Sub-Private/coverage/>
  743: 
  744: =item * L<Sub::Protected>
  745: 
  746: Sister module enforcing protected (owner + subclass) rather than strictly private access
  747: 
  748: =item * L<Sub::Abstract>
  749: 
  750: Sister module enforcing abstract (virtual) methods
  751: 
  752: =item * L<namespace::clean>
  753: 
  754: =back
  755: 
  756: =head1 FORMAL SPECIFICATION
  757: 
  758: The following Z-notation schemas formally specify the C<CheckAccess>
  759: operation and C<import>.
  760: 
  761: =head2 C<CheckAccess>
  762: 
  763:     -- Type abbreviations
  764:     Package  == seq CHAR     -- a non-empty Perl package name string
  765:     SubName  == seq CHAR     -- a Perl identifier string
  766: 
  767:     -- Private-access predicate (strictly owner only -- no isa expansion)
  768:     permitted : Package x Package -> BOOL
  769:     forall caller, owner : Package .
  770:         permitted(caller, owner) <=> caller = owner
  771: 
  772:     -- System state
  773:     +-Registry-------------------------------------------+
  774:     | private   : P (Package x SubName)                  |
  775:     | bypass    : BOOL                                    |
  776:     | config    : { mode : seq CHAR,                      |
  777:     |               harness_bypass : BOOL }               |
  778:     | pkg_mode  : Package -+> seq CHAR                   |
  779:     +----------------------------------------------------+
  780: 
  781:     -- Initial state
  782:     +-InitRegistry---------------------------------------+
  783:     | Registry                                           |
  784:     |----------------------------------------------------|
  785:     | private   = {}                                     |
  786:     | bypass    = false                                  |
  787:     | config    = { mode |-> 'namespace',                 |
  788:     |               harness_bypass |-> true }             |
  789:     | pkg_mode  = {}                                     |
  790:     +----------------------------------------------------+
  791: 
  792:     -- Bypass predicate
  793:     bypass_active(R) <=>
  794:         R.bypass or (R.config.harness_bypass and HARNESS_ACTIVE)
  795: 
  796:     -- Access check: no state change
  797:     +-CheckAccess----------------------------------------+
  798:     | Xi-Registry                                        |
  799:     | caller? : Package                                  |
  800:     | owner?  : Package                                  |
  801:     | name?   : SubName                                  |
  802:     | ok!     : BOOL                                     |
  803:     |----------------------------------------------------|
  804:     | (owner?, name?) in private                         |
  805:     | ok! <=> bypass_active or permitted(caller?, owner?)|
  806:     +----------------------------------------------------+
  807: 
  808:     -- Violation (croak case):
  809:     --   not ok! =>
  810:     --   croak("name?()" ++ " is a private subroutine of " ++ owner?
  811:     --         ++ " and cannot be called from " ++ caller?)
  812: 
  813:     -- Key difference from Sub::Protected:
  814:     --   permitted(caller, owner) <=> caller = owner   (identity only)
  815:     -- vs Sub::Protected:
  816:     --   permitted(caller, owner) <=> owner in anc(caller)   (ISA chain)
  817: 
  818: =head2 import
  819: 
  820:     -- Valid identifier predicate
  821:     valid_id : SubName -> BOOL
  822:     valid_id(n) <=> n =~ /\A[_a-zA-Z]\w*\z/
  823: 
  824:     -- Compile phase: CHECK has run, and code is still being compiled
  825:     post_check  : BOOL
  826:     compiling   : BOOL       -- true while $^S is undefined
  827: 
  828:     -- The mode that applies to a package's subs
  829:     mode_for(p) = pkg_mode(p)   if p in dom pkg_mode
  830:                 = config.mode   otherwise
  831: 
  832:     -- Options (hashref first): sets the caller's mode only
  833:     +-ImportOptions-------------------------------------+
  834:     | Delta-Registry                                    |
  835:     | mode? : seq CHAR                                  |
  836:     |---------------------------------------------------|
  837:     | mode? in { 'namespace', 'enforce' }               |
  838:     | pkg_mode' = pkg_mode (+) { caller |-> mode? }     |
  839:     | config' = config                                  |
  840:     +---------------------------------------------------+
  841: 
  842:     -- Pre-condition (declarative form)
  843:     +-ImportPre-----------------------------------------+
  844:     | mode_for(caller) = 'enforce'                      |
  845:     | forall n in subs . valid_id(n)                    |
  846:     +---------------------------------------------------+
  847: 
  848:     -- Post-condition (before CHECK): queue for the CHECK block
  849:     +-ImportPost_PreCheck-------------------------------+
  850:     | not post_check                                    |
  851:     |---------------------------------------------------|
  852:     | pending' = pending ++ < (caller, n) | n in subs > |
  853:     +---------------------------------------------------+
  854: 
  855:     -- Post-condition (after CHECK, at run time): wrap now
  856:     +-ImportPost_RunTime--------------------------------+
  857:     | post_check and not compiling                      |
  858:     | forall n in subs . defined(caller, n)             |
  859:     |---------------------------------------------------|
  860:     | forall n in subs .                                |
  861:     |   stash'(caller, n) = wrapper(caller, n)          |
  862:     +---------------------------------------------------+
  863: 
  864:     -- Post-condition (after CHECK, while compiling): wrap at the
  865:     -- end of the enclosing scope S
  866:     +-ImportPost_Deferred-------------------------------+
  867:     | post_check and compiling                          |
  868:     |---------------------------------------------------|
  869:     | at end_of_scope(S) :                              |
  870:     |   (forall n in subs . defined(caller, n)) =>      |
  871:     |     forall n in subs .                            |
  872:     |       stash'(caller, n) = wrapper(caller, n)      |
  873:     |   (exists n in subs . not defined(caller, n)) =>  |
  874:     |     croak at the "use" line                       |
  875:     +---------------------------------------------------+
  876: 
  877:     -- In every case, a sub that is not defined when wrapping is
  878:     -- attempted croaks:
  879:     --   "Sub::Private: " ++ caller ++ "::" ++ n ++ " is not defined"
  880: 
  881: =head1 AUTHOR
  882: 
  883: Original Author:
  884: Peter Makholm, C<< <peter at makholm.net> >>
  885: 
  886: Current maintainer:
  887: Nigel Horne, C<< <njh at nigelhorne.com> >>
  888: 
  889: =head1 BUGS
  890: 
  891: Please report any bugs or feature requests to C<bug-sub-private at rt.cpan.org>,
  892: or through the web interface at
  893: L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Private>.
  894: 
  895: =head1 SUPPORT
  896: 
  897:     perldoc Sub::Private
  898: 
  899: =over 4
  900: 
  901: =item * RT: CPAN's request tracker
  902: 
  903: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Sub-Private>
  904: 
  905: =item * MetaCPAN
  906: 
  907: L<https://metacpan.org/dist/Sub-Private>
  908: 
  909: =back
  910: 
  911: =head1 COPYRIGHT & LICENSE
  912: 
  913: Copyright 2009 Peter Makholm, all rights reserved.
  914: Portions copyright 2024-2026 Nigel Horne.
  915: 
  916: This program is free software; you can redistribute it and/or modify it
  917: under the same terms as Perl itself.
  918: 
  919: =cut