EVERYTHING FROM THE OTHER REPO

2026-07-29 03:36:26 +03:00
parent 6777ea96db
commit 92a6ae42f5
4426 changed files with 1696506 additions and 2 deletions
@@ -0,0 +1,119 @@
+package attributes;
+
+our $VERSION = 0.36;
+
+@EXPORT_OK = qw(get reftype);
+@EXPORT = ();
+%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
+
+use strict;
+
+sub croak {
+    require Carp;
+    goto &Carp::croak;
+}
+
+sub carp {
+    require Carp;
+    goto &Carp::carp;
+}
+
+# Hash of SV type (CODE, SCALAR, etc.) to regex matching deprecated
+# attributes for that type.
+my %deprecated;
+
+my %msg = (
+    lvalue => 'lvalue attribute applied to already-defined subroutine',
+   -lvalue => 'lvalue attribute removed from already-defined subroutine',
+    const  => 'Useless use of attribute "const"',
+);
+
+sub _modify_attrs_and_deprecate {
+    my $svtype = shift;
+    # After we've removed a deprecated attribute from the XS code, we need to
+    # remove it here, else it ends up in @badattrs. (If we do the deprecation in
+    # XS, we can't control the warning based on *our* caller's lexical settings,
+    # and the warned line is in this package)
+    grep {
+	$deprecated{$svtype} && /$deprecated{$svtype}/ ? do {
+	    require warnings;
+	    warnings::warnif('deprecated', "Attribute \"$1\" is deprecated, " .
+                                           "and will disappear in Perl 5.28");
+	    0;
+	} : $svtype eq 'CODE' && exists $msg{$_} ? do {
+	    require warnings;
+	    warnings::warnif(
+		'misc',
+		 $msg{$_}
+	    );
+	    0;
+	} : 1
+    } _modify_attrs(@_);
+}
+
+sub import {
+    @_ > 2 && ref $_[2] or do {
+	require Exporter;
+	goto &Exporter::import;
+    };
+    my (undef,$home_stash,$svref,@attrs) = @_;
+
+    my $svtype = uc reftype($svref);
+    my $pkgmeth;
+    $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
+	if defined $home_stash && $home_stash ne '';
+    my @badattrs;
+    if ($pkgmeth) {
+	my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
+	@badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
+	if (!@badattrs && @pkgattrs) {
+            require warnings;
+	    return unless warnings::enabled('reserved');
+	    @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
+	    if (@pkgattrs) {
+		for my $attr (@pkgattrs) {
+		    $attr =~ s/\(.+\z//s;
+		}
+		my $s = ((@pkgattrs == 1) ? '' : 's');
+		carp "$svtype package attribute$s " .
+		    "may clash with future reserved word$s: " .
+		    join(' : ' , @pkgattrs);
+	    }
+	}
+    }
+    else {
+	@badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
+    }
+    if (@badattrs) {
+	croak "Invalid $svtype attribute" .
+	    (( @badattrs == 1 ) ? '' : 's') .
+	    ": " .
+	    join(' : ', @badattrs);
+    }
+}
+
+sub get ($) {
+    @_ == 1  && ref $_[0] or
+	croak 'Usage: '.__PACKAGE__.'::get $ref';
+    my $svref = shift;
+    my $svtype = uc reftype($svref);
+    my $stash = _guess_stash($svref);
+    $stash = caller unless defined $stash;
+    my $pkgmeth;
+    $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
+	if defined $stash && $stash ne '';
+    return $pkgmeth ?
+		(_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
+		(_fetch_attrs($svref))
+	;
+}
+
+sub require_version { goto &UNIVERSAL::VERSION }
+
+require XSLoader;
+XSLoader::load();
+
+1;
+__END__
+#The POD goes here
+