lib/Sub/Protected.pm

        start → end → jump
        

    1: package Sub::Protected;
    2: 
    3: # Minimum Perl version: 5.10 (the // operator; several dependencies need it).
    4: # Loading after CHECK (require, string eval) also needs 5.14: see LIMITATIONS.
    5: use 5.010;
    6: use strict;
    7: use warnings;
    8: 
    9: use Carp              qw(croak);
   10: use Attribute::Handlers;
   11: use Readonly;
   12: use Params::Get       qw(get_params);
   13: use Params::Validate::Strict 0.33 qw(validate_strict);
   14: use Return::Set       qw(set_return);
   15: 
   16: our $VERSION = '0.03';
   17: 
   18: # Public bypass flag.  Set to a true value to disable all access checks.
   19: # Use C<local $Sub::Protected::BYPASS = 1> in test code; see BYPASS section.
   20: our $BYPASS = 0;
   21: 
   22: # Module-level configuration hash.
   23: # Can be modified directly or injected via Object::Configure.
   24: our %config = (
   25: 	# When true, access checks are skipped if $ENV{HARNESS_ACTIVE} is set.
   26: 	# Set to 0 to test protection behaviour from within a test harness.
   27: 	harness_bypass => 1,
   28: );
   29: 
   30: # Self-referential constant: the name of this package.
   31: # Used to identify our own frames in the call-stack walk.
   32: Readonly::Scalar my $SELF => __PACKAGE__;
   33: 
   34: # Validation schema for a single Perl sub name passed to import().
   35: Readonly::Scalar my $SUB_NAME_SCHEMA => {
   36: 	name => {
   37: 		type  => 'string',
   38: 		regex => qr/\A[_a-zA-Z]\w*\z/,
   39: 	}
   40: };
   41: 
   42: # Pending (owner_pkg, sub_name) pairs to be wrapped at CHECK time.
   43: # Populated by import(); consumed and cleared by the CHECK block.
   44: my @_pending;
   45: 
   46: # Set to 1 when the CHECK block fires.  Import() uses this to decide
   47: # whether to schedule wrapping (pre-CHECK) or wrap immediately (post-CHECK).
   48: # If this module is itself loaded after CHECK (run-time require, plugin
   49: # loader, string eval) our CHECK block never runs, so start from the global
   50: # phase.  ${^GLOBAL_PHASE} exists from Perl 5.14; on older Perls it is undef
   51: # and the flag starts at 0, so the module must be loaded at compile time.
   52: my $_post_check = (defined(${^GLOBAL_PHASE}) && ${^GLOBAL_PHASE} ne 'START') ? 1 : 0;
   53: 
   54: # -------------------------------------------------------------------
   55: # ATTRIBUTE HANDLER
   56: # -------------------------------------------------------------------
   57: 
   58: # Another module may already own UNIVERSAL::Protected (a :Protected attribute
   59: # of its own).  Redefining it would silently change that module's behaviour,
   60: # so say so loudly.  This runs before the sub below is compiled.
   61: BEGIN {
   62: 	Carp::carp(__PACKAGE__ . ": UNIVERSAL::Protected is already defined; another module's :Protected attribute will be replaced")
   63: 		if defined &UNIVERSAL::Protected;
   64: }
   65: 
   66: # Install the :Protected attribute in UNIVERSAL so every package can use it
   67: # the moment this module is loaded, with no per-package setup needed.
   68: # Attribute::Handlers calls this sub at CHECK phase for each decorated symbol.
   69: # It is also called at BEGIN phase: before CHECK that call does nothing (the
   70: # CHECK-phase call does the work), but after CHECK the CHECK-phase call never
   71: # happens, so the BEGIN-phase call wraps the sub instead.  The sub is still
   72: # being compiled at that point and may have no name yet, so the wrapping is
   73: # deferred to the end of the scope (normally the file) being compiled.
  Mutants (Total: 1, Killed: 1, Survived: 0)
   74: # on_scope_end() works here because a BEGIN-phase handler runs while the
   75: # user's file is being compiled; it does NOT work from a CHECK-phase callback.
   76: # The unused parameters ($attr, $data) are required by the protocol.
   77: sub UNIVERSAL::Protected : ATTR(CODE,BEGIN,CHECK) {
●78 → 80 → 92   78: 	my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
   79: 
   80: 	if($phase eq 'BEGIN') {
   81: 		return unless($_post_check);	# CHECK will do it
   82: 		require B::Hooks::EndOfScope;
   83: 		require Sub::Identify;
   84: 		B::Hooks::EndOfScope::on_scope_end(sub {
   85: 			my ($pkg, $name) = Sub::Identify::get_code_info($referent);
   86: 			no strict 'refs';
   87: 			UNIVERSAL::Protected($pkg, \*{"${pkg}::$name"}, $referent, $attr, $data, 'CHECK');
   88: 		});
   89: 		return;
   90: 	}
   91: 
   92: 	my $sub_name = *{$symbol}{NAME};
   93: 	no warnings 'redefine';
   94: 	*{$symbol} = _wrap($package, $sub_name, $referent);  # function call, not method call
   95: 	return;
   96: }
   97: 
   98: # -------------------------------------------------------------------
   99: # PUBLIC INTERFACE
  100: # -------------------------------------------------------------------
  101: 
  102: =head1 NAME
  103: 
  104: Sub::Protected - Enforce protected subroutine access (Java/C++ semantics)
  105: 
  106: =head1 VERSION
  107: 
  108: 0.03
  109: 
  110: =head1 SYNOPSIS
  111: 
  112:     package Foo;
  113:     use Sub::Protected;              # enables the :Protected attribute
  114: 
  115:     sub new { bless {}, shift }
  116: 
  117:     # Attribute form (preferred: protection lives next to the definition)
  118:     sub _helper :Protected {
  119:         ...
  120:     }
  121: 
  122:     sub public_method {
  123:         my $self = shift;
  124:         $self->_helper;              # OK -- same package
  125:     }
  126: 
  127:     # ----------------------------------------------------------------
  128: 
  129:     package Bar;
  130:     use Sub::Protected qw(_other _private);   # declarative form
  131: 
  132:     sub _other   { 'other'   }
  133:     sub _private { 'private' }
  134: 
  135: =head1 DESCRIPTION
  136: 
  137: Enforces Java/C++-style "protected" access at runtime: a subroutine
  138: decorated with C<:Protected> (or named in C<use Sub::Protected qw(...)>)
  139: may only be called from within its defining package or from a subclass of
  140: that package.  Any other caller causes a C<Carp::croak> with a descriptive
  141: message.
  142: 
  143: =head2 Two usage forms
  144: 
  145: =over 4
  146: 
  147: =item Attribute form (preferred)
  148: 
  149:     sub _helper :Protected { ... }
  150: 
  151: The C<:Protected> attribute is registered in C<UNIVERSAL> via
  152: L<Attribute::Handlers> when C<Sub::Protected> is loaded, so every package
  153: has access to it without any further C<use> or inheritance.  The sub is
  154: wrapped at C<CHECK> time, or, if the module is loaded after C<CHECK> (Perl
  155: 5.14 or later), at the end of the file being compiled.  This form is preferred because the protection
  156: declaration sits next to the definition and wrapping happens at compile time
  157: (making pre-wrap raw-coderef captures impossible).
  158: 
  159: =item Declarative form
  160: 
  161:     use Sub::Protected qw(_helper _other);
  162: 
  163: Each named sub is looked up in the caller's stash and wrapped at C<CHECK>
  164: time (or immediately if the module is loaded at runtime via C<require>).
  165: All named subs must be defined before C<CHECK> fires -- i.e. they must be
  166: compile-time named subs in the same file, not generated at runtime.
  167: 
  168: =back
  169: 
  170: =head2 Bypass for testing
  171: 
  172: Either condition alone (OR logic) disables all access checks:
  173: 
  174: =over 4
  175: 
  176: =item * C<$Sub::Protected::BYPASS> set to a true value.  Use C<local> in tests.
  177: 
  178: =item * C<$ENV{HARNESS_ACTIVE}> set (the convention used by L<Test::Harness>/prove).
  179: 
  180: =back
  181: 
  182: C<$Sub::Protected::BYPASS> is the recommended form for new test code;
  183: it is explicit and does not depend on the test runner.
  184: C<HARNESS_ACTIVE> is a zero-config convenience.
  185: 
  186: The HARNESS_ACTIVE bypass can be disabled by setting:
  187: 
  188:     $Sub::Protected::config{harness_bypass} = 0;
  189: 
  190: =head2 Configuration
  191: 
  192: The module exposes C<%Sub::Protected::config> for runtime configuration:
  193: 
  194: =over 4
  195: 
  196: =item C<harness_bypass> (default: 1)
  197: 
  198: When true, access checks are skipped whenever C<$ENV{HARNESS_ACTIVE}> is
  199: set.  Set to 0 to test protection behaviour from within a test harness.
  200: 
  201: =back
  202: 
  203: The hash is compatible with L<Object::Configure> for dependency-injection
  204: scenarios.
  205: 
  206: =head2 Error message format
  207: 
  208:     _helper() is a protected method of Foo and cannot be called from Bar
  209: 
  210: The error is raised with L<Carp/croak>, so it reports the file and line of
  211: the offending call, not a line inside Sub::Protected.
  212: 
  213: =head2 How access is decided
  214: 
  215: =over 4
  216: 
  217: =item * Only the immediate caller counts
  218: 
  219: The decision is made on the package of the code that called the protected
  220: sub.  If C<Bar::run> calls C<Foo::public>, which calls C<Foo::_helper>, the
  221: call is allowed: the immediate caller is C<Foo>.  If C<Foo::public> instead
  222: calls a C<Bar> method that calls C<Foo::_helper>, it is blocked, however
  223: deep the chain.
  224: 
  225: =item * Subclasses are allowed
  226: 
  227: A caller whose package C<isa> the owner is allowed, so calls through
  228: C<SUPER::>, C<< $self->can('_helper') >> and ordinary inherited method
  229: calls all work from a subclass.
  230: 
  231: =item * The wrapper is invisible
  232: 
  233: The wrapper hands over with C<goto &sub>, so inside the protected sub
  234: C<caller()> reports the real caller, not Sub::Protected.  Arguments
  235: (including aliasing of C<@_>), calling context (list, scalar or void) and
  236: return values, including false ones, pass through unchanged.
  237: 
  238: =back
  239: 
  240: =head1 PUBLIC INTERFACE
  241: 
  242: =head2 import
  243: 
  244:     use Sub::Protected;                    # attribute form -- no arguments
  245:     use Sub::Protected qw(_a _b _c);      # declarative form
  246: 
  247: =head3 Purpose
  248: 
  249: Called automatically by C<use Sub::Protected>.
  250: 
  251: With B<no arguments>: does nothing beyond making the C<:Protected> attribute
  252: globally available (which happens when the module is first loaded).
  253: 
  254: With B<one or more sub names>: registers those subs in the calling
  255: package for wrapping at C<CHECK> time.  If C<CHECK> has already fired
  256: (e.g. the module was loaded via runtime C<require>, a plugin loader or a
  257: string C<eval>), wrapping is applied immediately.
  258: Each named sub must be defined before C<CHECK> fires (for pre-CHECK loads)
  259: or before C<import> is called (for post-CHECK loads), so a module loaded at
  260: run time should call C<< Sub::Protected->import(...) >> at the end of the
  261: file, after its subs are defined.
  262: 
  263: Run-time loading needs Perl 5.14 or later.  On older Perls the module must
  264: be loaded at compile time (C<use>, or C<require> inside C<BEGIN>).
  265: 
  266: =head3 Arguments
  267: 
  268: =over 4
  269: 
  270: =item C<$class> (positional, required)
  271: 
  272: The name of the importing class.  Set automatically by the C<use> mechanism.
  273: Must be a non-empty string.
  274: 
  275: =item C<@subs> (positional, optional)
  276: 
  277: Zero or more sub names to protect in the calling package.  Each must be a
  278: valid Perl identifier: matching C</\A[_a-zA-Z]\w*\z/>.
  279: 
  280: These calls are equivalent:
  281: 
  282:     Sub::Protected->import(qw(_a _b));
  283:     Sub::Protected->import([ qw(_a _b) ]);
  284:     Sub::Protected->import({ subs => [ qw(_a _b) ] });
  285: 
  286: A plain list is always a list of names, so C<qw(subs _x)> protects both
  287: C<subs> and C<_x>.  A single arrayref or hashref is normalised by
  288: L<Params::Get>.
  289: 
  290: =back
  291: 
  292: =head3 Returns
  293: 
  294: C<$class> (the importing class name).  The return value is ignored by the
  295: C<use> mechanism; it is provided for optional method chaining at the class
  296: level.
  297: 
  298: =head3 Side effects
  299: 
  300: =over 4
  301: 
  302: =item *
  303: 
  304: Each supplied sub name is appended to an internal pending list (if pre-CHECK)
  305: or wrapped immediately (if post-CHECK).
  306: 
  307: =item *
  308: 
  309: The pending list is consumed and cleared when the CHECK block fires.
  310: 
  311: =item *
  312: 
  313: C<$@>, C<$!> and C<$_> are left unchanged, as are any pending C<alarm()>
  314: timers.
  315: 
  316: =back
  317: 
  318: =head3 Example
  319: 
  320:     package Foo;
  321:     use Sub::Protected qw(_helper _init);
  322: 
  323:     sub _helper { ... }   # will be protected
  324:     sub _init   { ... }   # will be protected
  325: 
  326: =head3 API SPECIFICATION
  327: 
  328: =head4 Input
  329: 
  330:     # Params::Get::get_params / Params::Validate::Strict schema
  331:     {
  332:         # class is the implicit first argument, set by Perl's 'use' mechanism
  333:         subs => {
  334:             type     => 'array',
  335:             required => 0,
  336:             each     => {
  337:                 type  => 'string',
  338:                 regex => qr/\A[_a-zA-Z]\w*\z/,
  339:             },
  340:         },
  341:     }
  342: 
  343: =head4 Output
  344: 
  345:     # Return::Set schema
  346:     {
  347:         type    => 'string',
  348:         desc    => 'The importing class name ($class), for optional chaining.',
  349:     }
  350: 
  351: =head3 MESSAGES
  352: 
  353: The following table lists every error or warning this method can produce.
  354: 
  355:     Message                                     Meaning
  356:     ----------------------------------------	-------------------------------------
  357:     "Sub::Protected->import: 'NAME' is not a    A sub name passed to import() failed
  358:      valid Perl identifier"                      the identifier regex.  Use a name
  359:                                                  matching /\A[_a-zA-Z]\w*\z/.
  360:                                                  NAME is shown as '' when the
  361:                                                  name was undef or a reference.
  362: 
  363:     "Sub::Protected: PKG::NAME is not defined"  The named sub was not found in the
  364:                                                  package stash at wrap time.  For
  365:                                                  pre-CHECK loads, ensure the sub is
  366:                                                  a compile-time named sub.  For
  367:                                                  post-CHECK/runtime loads, ensure
  368:                                                  the sub is defined before import().
  Mutants (Total: 2, Killed: 2, Survived: 0)
  369: 
  370: Calling a protected sub from outside its package or subclasses croaks
  371: with the message shown in L</Error message format>.
  372: 
  373: =encoding utf8
  374: 
  375: =head3 FORMAL SPECIFICATION
  376: 
  377:     ValidName ≙ { n : seq CHAR | n matches /\A[_a-zA-Z]\w*\z/ }
  378: 
  379:     ┌─ Import ──────────────────────────────────────────
  380:     │ ΔRegistry
  381:     │ class? : Package ; caller? : Package
  382:     │ names? : seq SubName ; postCheck : 𝔹
  383:     │ result! : Package
  384:     ├───────────────────────────────────────────────────
  385:     │ ∀ n ∈ ran names? • n ∈ ValidName
  386:     │ postCheck ⇒ (∀ n ∈ ran names? • defined(caller?, n))
  387:     │ postCheck ⇒ protected′ = protected ∪ { n : ran names? • (caller?, n) }
  388:     │ ¬postCheck ⇒ pending′ = pending ⁀ ⟨ n : names? • (caller?, n) ⟩
  389:     │ result! = class?
  390:     └───────────────────────────────────────────────────
  391: 
  392:     -- Failure cases (croak, Registry unchanged):
  Mutants (Total: 1, Killed: 1, Survived: 0)
  393:     --   ∃ n ∈ ran names? • n ∉ ValidName
  394:     --     ⇒ "Sub::Protected->import: 'n' is not a valid Perl identifier"
  395:     --   postCheck ∧ ∃ n ∈ ran names? • ¬defined(caller?, n)
  396:     --     ⇒ "Sub::Protected: caller?::n is not defined"
  397: 
  398: =cut
  399: 
  400: sub import {
  Mutants (Total: 2, Killed: 2, Survived: 0)
●401 → 410 → 421  401: 	my ($class, @subs) = @_;
  402: 
  403: 	# No sub names: the :Protected attribute is always active via UNIVERSAL.
  404: 	return _return_class($class) unless @subs;
  405: 
  406: 	# A plain list is always a list of names.  Only a single arrayref or
  407: 	# hashref goes through Params::Get: passing a plain list to it would read
  408: 	# qw(subs _x) as subs => '_x', silently leaving a sub called subs open.
  409: 	my @names = @subs;
  410: 	if (@subs == 1 && ref($subs[0]) && ref($subs[0]) ne 'CODE') {
  411: 		my $args = get_params('subs', \@subs);
  412: 		@names = ref($args->{subs}) eq 'ARRAY'
  413: 			? @{$args->{subs}}
  414: 			: ($args->{subs});
  415: 	}
  416: 
  417: 	# Validate each name against the schema; validate_strict croaks on failure.
  418: 	# Params::Validate::Strict silently accepts undef for type => 'string', so
  419: 	# we coerce undef and references to '' so the regex check fires for them.
  420: 	# local $@ so a successful eval does not clear the caller's $@.
●421 → 421 → 432  421: 	for my $sub_name (@names) {
  422: 		my $check = (defined $sub_name && !ref $sub_name) ? $sub_name : q{};
  423: 		my $valid = do {
  424: 			local $@;
  425: 			eval { validate_strict(schema => $SUB_NAME_SCHEMA, input => { name => $check }); 1 };
  426: 		};
  427: 		croak "$SELF->import: '$check' is not a valid Perl identifier"
  428: 			unless $valid;
  429: 	}
  430: 
  431: 	# Schedule or immediately apply wrapping depending on compilation phase.
●432 → 433 → 441  432: 	my $owner_pkg = caller;
  433: 	if ($_post_check) {
  434: 		# Module was loaded at runtime (past CHECK): wrap immediately.
  435: 		_process_one($owner_pkg, $_) for @names;
  436: 	} else {
  Mutants (Total: 2, Killed: 2, Survived: 0)
  437: 		# Pre-CHECK: register for the CHECK block to process.
  438: 		push @_pending, [ $owner_pkg, $_ ] for @names;
  439: 	}
  440: 
  441: 	return _return_class($class);
  442: }
  443: 
  444: # -------------------------------------------------------------------
  445: # CHECK-TIME PROCESSING
  446: # -------------------------------------------------------------------
  447: 
  448: # Process all pending declarative wraps registered during import().
  449: # After processing, set the post_check flag so runtime imports wrap directly.
  450: # The bare block silences "Too late to run CHECK block" when this module is
  451: # loaded after CHECK; $_post_check is already 1 in that case.
  452: {
  453: 	no warnings 'void';	# "Too late to run CHECK block"
  454: 	CHECK {
  455: 		$_post_check = 1;
  456: 
  457: 		# Wrap every pending (package, sub) pair.
  458: 		_process_one(@$_) for @_pending;
  459: 		@_pending = ();
  460: 	}
  461: }
  462: 
  463: # -------------------------------------------------------------------
  464: # PRIVATE SUBROUTINES
  465: # -------------------------------------------------------------------
  466: 
  467: # _return_class
  468: # Purpose:    Validate and return import()'s return value.
  469: # Entry:      ($class) -- the importing class name.
  470: # Exit:       Returns $class, checked against the documented string schema.
  471: # Notes:      Return::Set::set_return clears $@ even when it succeeds, and
  472: #             import() promises to leave $@ alone, so it is localised here.
  473: sub _return_class {
  474: 	my ($class) = @_;
  475: 
  476: 	local $@;
  477: 	return set_return($class, { type => 'string' });
  478: }
  479: 
  480: # _process_one
  481: # Purpose:    Look up a named sub in a package's stash and wrap it.
  482: #             Called from the CHECK block and from import() (post-CHECK).
  483: # Entry:      ($owner_pkg, $sub_name) -- both non-empty strings;
  484: #             $owner_pkg::$sub_name must be defined in the stash.
  485: # Exit:       The stash entry is replaced with the wrapper closure.
  486: #             Croaks if the sub is not defined.
  487: # Side effects: Modifies the caller package's stash (redefines the named glob).
  Mutants (Total: 2, Killed: 2, Survived: 0)
  488: # Notes:      Uses 'no warnings redefine' because the whole point is replacement.
  489: sub _process_one {
  490: 	my ($owner_pkg, $sub_name) = @_;
  491: 
  492: 	# Guard: only Sub::Protected code should call this.
  493: 	_assert_private_caller('_process_one')
  494: 		unless $BYPASS || ($config{harness_bypass} && $ENV{HARNESS_ACTIVE});
  495: 
  496: 	no strict 'refs';
  497: 
  498: 	# Abort clearly when the sub was never defined.
  499: 	croak "$SELF: ${owner_pkg}::${sub_name} is not defined"
  500: 		unless defined &{"${owner_pkg}::${sub_name}"};
  501: 
  502: 	my $code = \&{"${owner_pkg}::${sub_name}"};
  503: 	no warnings 'redefine';
  504: 	*{"${owner_pkg}::${sub_name}"} = _wrap($owner_pkg, $sub_name, $code);
  505: 	return;
  506: }
  507: 
  508: # _wrap
  509: # Purpose:    Construct the protection wrapper closure around a coderef.
  510: # Entry:      ($owner_pkg, $sub_name, $code) -- all defined; $code is a CODE ref.
  511: # Exit:       Returns a new anonymous CODE ref (the wrapper closure).
  512: #               At call time: calls _check_access (may croak), then $code.
  513: # Notes:      'goto &$code' is a deliberate, necessary exception to the
  514: #             "avoid goto" guideline.  It replaces the wrapper's stack frame
  515: #             with $code's frame so that caller() inside the protected body
  516: #             sees the real caller, not 'Sub::Protected'.  Replacing with
  517: #             $code->(@_) would make caller(0) return 'Sub::Protected' inside
  518: #             the protected sub, breaking any code there that inspects its
  519: #             caller.  Do NOT change this without updating t/caller_integrity.t.
  520: sub _wrap {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  521: 	my ($owner_pkg, $sub_name, $code) = @_;
  522: 
  523: 	# Guard: only Sub::Protected code (and its subclasses) should call _wrap.
  524: 	_assert_private_caller('_wrap')
  525: 		unless $BYPASS || ($config{harness_bypass} && $ENV{HARNESS_ACTIVE});
  526: 
  Mutants (Total: 1, Killed: 1, Survived: 0)
  527: 	# Return the wrapper.  The goto is load-bearing -- see Notes above.
  528: 	return sub {
  529: 		Sub::Protected::_check_access($owner_pkg, $sub_name);
  530: 		goto &$code;    ## no critic (ControlStructures::ProhibitGoto)
  531: 	};
  532: }
  533: 
  534: # _check_access
  535: # Purpose:    Enforce the protected-access invariant at call time.
  536: #             Walk the call stack (skipping Sub::Protected frames) to find
  537: #             the first external frame, then allow or croak based on the
  538: #             owner/isa relationship.
  539: # Entry:      ($owner_pkg, $sub_name) -- both defined strings.
  540: #             The current stack has the wrapper closure at the top (frame 0),
  541: #             followed by the real caller.
  542: # Exit:       Returns normally (undef) if access is permitted.
  543: #             Croaks with a descriptive message if access is denied.
  544: # Notes:      Frame index starts at 0 (= the wrapper closure that called us).
  545: #             The walk increments until a non-Sub::Protected package appears.
  546: #             This approach is robust against SUPER:: chains, can() delegation,
  547: #             and XS frames that may insert extra frames.
  548: sub _check_access {
●549 → 557 → 0  549: 	my ($owner_pkg, $sub_name) = @_;
  550: 
  551: 	# Short-circuit on bypass (OR logic: either condition alone is sufficient).
  552: 	return if $BYPASS;
  553: 	return if $config{harness_bypass} && $ENV{HARNESS_ACTIVE};
  554: 
  555: 	# Walk the stack to find the real (first non-SP) caller.
  556: 	my $frame = 0;
  557: 	while (1) {
  558: 		my $pkg = (caller($frame))[0];
  559: 
  560: 		# No package found: reached the top of the stack.
  561: 		if (!defined $pkg) {
  562: 			croak "${sub_name}() is a protected method of ${owner_pkg}"
  563: 				. ' and cannot be called outside any package context';
  564: 		}
  565: 
  566: 		# Skip Sub::Protected's own frames (wrapper closure, _check_access).
  567: 		if ($pkg eq $SELF) {
  568: 			$frame++;
  569: 			next;
  570: 		}
  571: 
  572: 		# Found the real caller: allow if owner or subclass, else croak.
  573: 		return if $pkg eq $owner_pkg || $pkg->isa($owner_pkg);
  574: 
  575: 		croak "${sub_name}() is a protected method of ${owner_pkg}"
  576: 			. " and cannot be called from ${pkg}";
  577: 	}
  578: }
  579: 
  580: # _assert_private_caller
  581: # Purpose:    Croak if the guarded private method was called from outside
  582: #             Sub::Protected (or a subclass).  Used to enforce visibility.
  583: # Entry:      ($method_name) -- name of the guarded method, used in the message.
  584: #             Must be called directly (not nested deeper) inside the guarded method.
  585: # Exit:       Returns normally if the caller is Sub::Protected or a subclass.
  586: #             Croaks with a descriptive message otherwise.
  587: # Side effects: Calls Carp::croak on failure.
  588: # Notes:      caller() semantics from inside this sub:
  589: #               caller(0) -- the package in which the call TO this sub was made.
  590: #                            That is the guarded method's package = Sub::Protected.
  591: #               caller(1) -- the package in which the call TO the guarded method
  592: #                            was made.  That is the actual external caller to check.
  593: sub _assert_private_caller {
  594: 	my ($method_name) = @_;
  595: 
  596: 	# caller(1): the package that invoked the guarded method directly.
  597: 	my $caller = (caller(1))[0] // q{};
  598: 	return if $caller eq $SELF || eval { $caller->isa($SELF) };
  599: 
  600: 	croak "${method_name}() is a private method of $SELF"
  601: 		. " and cannot be called from ${caller}";
  602: }
  603: 
  604: 1;
  605: 
  606: __END__
  607: 
  608: =head1 KNOWN LIMITATIONS
  609: 
  610: =over 4
  611: 
  612: =item Runtime-only
  613: 
  614: Checks are runtime only; there is no compile-time enforcement.
  615: 
  616: =item Raw coderef bypass
  617: 
  618: A raw code reference obtained B<before> wrapping (via C<can()> or direct
  619: C<\&Foo::_helper>) bypasses the check.  The attribute form prevents this
  620: because wrapping happens at compile time.
  621: 
  622: =item Moo/Moose method modifiers
  623: 
  624: Method modifiers applied after Sub::Protected has wrapped a sub will wrap
  625: the wrapper.  Apply Sub::Protected last, or use the declarative form in a
  626: C<CHECK> block after the class is fully built.
  627: 
  628: =item Run-time loading on Perl < 5.14
  629: 
  630: On Perls older than 5.14, loading this module (or a package that uses it)
  631: at run time -- via C<require>, a plugin loader or a string C<eval> -- leaves
  632: the subs unprotected, because C<CHECK> has already fired.  Load it at
  633: compile time instead.
  634: 
  635: =item UNIVERSAL namespace pollution
  636: 
  637: The C<:Protected> attribute is installed in C<UNIVERSAL>, which is
  638: intentional (any package can use it after a single C<use>), but it does
  639: introduce C<UNIVERSAL::Protected> into the global namespace.  If another
  640: module has already defined C<UNIVERSAL::Protected>, loading Sub::Protected
  641: warns that it is being replaced.
  642: 
  643: =item Thread safety
  644: 
  645: C<@_pending> and C<$BYPASS> are unguarded package globals.  Subs are
  646: normally wrapped before any thread is started, which is safe.  Calling
  647: C<< Sub::Protected->import(...) >> or loading a package that uses
  648: Sub::Protected from more than one thread at once is not supported.
  649: C<$BYPASS> is per-thread, as with any C<our> variable under ithreads.
  650: 
  651: =back
  652: 
  653: =head1 DEPENDENCIES
  654: 
  655: L<Carp> (core),
  656: L<Attribute::Handlers> (core since 5.8),
  657: L<B::Hooks::EndOfScope>,
  658: L<Readonly>,
  659: L<Sub::Identify>,
  660: L<Params::Get>,
  661: L<Params::Validate::Strict>,
  662: L<Return::Set>.
  663: 
  664: =head1 SEE ALSO
  665: 
  666: =over 4
  667: 
  668: =item * L<Test Dashboard|https://nigelhorne.github.io/Sub-Protected/coverage/>
  669: 
  670: =item * L<Sub::Abstract>
  671: 
  672: Sister module enforcing abstract (virtual) methods
  673: 
  674: =item * L<Sub::Private>
  675: 
  676: Sister module enforcing strictly private (owner-only) access.
  677: 
  678: =back
  679: 
  680: L<Attribute::Handlers>, L<Carp>, L<Readonly>, L<Params::Get>,
  681: L<Params::Validate::Strict>, L<Return::Set>.
  682: 
  683: =head1 FORMAL SPECIFICATION
  684: 
  685: =head2 import
  686: 
  687: The following Z-notation schemas formally specify the state and operations
  688: of Sub::Protected.  Unicode mathematical symbols are used in this section
  689: only.
  690: 
  691:     -- Type abbreviations
  692:     Package  == seq CHAR     -- a non-empty Perl package name string
  693:     SubName  == seq CHAR     -- a Perl identifier string
  694:     Proc     == seq CHAR     -- abstract: a callable code reference
  695: 
  696:     -- Ancestry relation (derived dynamically from @ISA chains)
  697:     anc : Package -> P Package
  698:     forall p : Package .
  699:         anc p = {p} union bigcup { anc r | r in @ISA_of(p) }
  700: 
  701:     -- Protected-access predicate
  702:     permitted : Package x Package -> BOOL
  703:     forall caller, owner : Package .
  704:         permitted(caller, owner) <=> owner in anc(caller)
  705: 
  706:     -- System state
  707:     +-Registry-------------------------------------------+
  708:     | protected : P (Package x SubName)                  |
  709:     | bypass    : BOOL                                   |
  710:     | config    : { harness_bypass : BOOL }              |
  711:     +----------------------------------------------------+
  712: 
  713:     -- Initial state
  714:     +-InitRegistry---------------------------------------+
  715:     | Registry                                           |
  716:     |----------------------------------------------------|
  717:     | protected = {}                                     |
  718:     | bypass    = false                                  |
  719:     | config    = { harness_bypass |-> true }            |
  720:     +----------------------------------------------------+
  721: 
  722:     -- Wrap: add a sub to the protected registry
  723:     +-Wrap-----------------------------------------------+
  724:     | Delta-Registry                                     |
  725:     | pkg? : Package ; name? : SubName                   |
  726:     |----------------------------------------------------|
  727:     | protected' = protected union { (pkg?, name?) }     |
  728:     | bypass'    = bypass                                |
  729:     | config'    = config                                |
  730:     +----------------------------------------------------+
  731: 
  732:     -- Bypass predicate
  733:     bypass_active(R) <=>
  734:         R.bypass or (R.config.harness_bypass and HARNESS_ACTIVE)
  735: 
  736:     -- Access check: no state change
  737:     +-CheckAccess----------------------------------------+
  738:     | Xi-Registry                                        |
  739:     | caller? : Package                                  |
  740:     | owner?  : Package                                  |
  741:     | name?   : SubName                                  |
  742:     | ok!     : BOOL                                     |
  743:     |----------------------------------------------------|
  744:     | (owner?, name?) in protected                       |
  745:     | ok! <=> bypass_active or permitted(caller?, owner?)|
  746:     +----------------------------------------------------+
  747: 
  748:     -- Violation (croak case):
  749:     --   not ok! =>
  750:     --   croak("name?()" ++ " is a protected method of " ++ owner?
  751:     --         ++ " and cannot be called from " ++ caller?)
  752: 
  753: =head1 AUTHOR
  754: 
  755: Nigel Horne, C<< <njh at nigelhorne.com> >>
  756: 
  757: =head1 LICENCE AND COPYRIGHT
  758: 
  759: Copyright 2026 Nigel Horne.
  760: 
  761: Usage is subject to the GPL2 licence terms.
  762: If you use it,
  763: please let me know.
  764: 
  765: =cut