Why am I not getting a warning from Perl? - perl

Question

Consider these two use cases:
sub test1 {
my $v = 1;
sub test2 { print $v }
# ...
}
and
for (0..3) {
my $foo = $_;
sub test1 { print $foo }
# ...
}
The first one produces a Variable will not stay shared warning, while the second doesn't. It seems that the variable is not shared in both cases. Why isn't there any warning in the second case?

Answer 1

It seems that this may be a bug or omission in the warnings pragma.
Adding to the fun, this arrangement gives a different warning:
BEGIN {*outer = sub {
my $x;
sub inner {$x}
}}
Which warns Variable "$x" is not available
These warnings all come from the pad_findlex() API call defined in pad.c.
806 =for apidoc pad_findlex
807
808 Find a named lexical anywhere in a chain of nested pads. Add fake entries
809 in the inner pads if it's found in an outer one.
810
811 Returns the offset in the bottom pad of the lex or the fake lex.
812 cv is the CV in which to start the search, and seq is the current cop_seq
813 to match against. If warn is true, print appropriate warnings. The out_*
814 vars return values, and so are pointers to where the returned values
815 should be stored. out_capture, if non-null, requests that the innermost
816 instance of the lexical is captured; out_name_sv is set to the innermost
817 matched namesv or fake namesv; out_flags returns the flags normally
818 associated with the IVX field of a fake namesv.
819
820 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
821 then comes back down, adding fake entries as it goes. It has to be this way
822 because fake namesvs in anon protoypes have to store in xlow the index into
823 the parent pad.
824
825 =cut
826 */
827
828 /* the CV has finished being compiled. This is not a sufficient test for
829 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
830 #define CvCOMPILED(cv) CvROOT(cv)
831
832 /* the CV does late binding of its lexicals */
833 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
834
835
836 STATIC PADOFFSET
837 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
838 SV** out_capture, SV** out_name_sv, int *out_flags)
839 {
840 dVAR;
841 I32 offset, new_offset;
842 SV *new_capture;
843 SV **new_capturep;
844 const AV * const padlist = CvPADLIST(cv);
845
846 PERL_ARGS_ASSERT_PAD_FINDLEX;
847
848 *out_flags = 0;
849
850 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
851 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
852 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
853
854 /* first, search this pad */
855
856 if (padlist) { /* not an undef CV */
857 I32 fake_offset = 0;
858 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
859 SV * const * const name_svp = AvARRAY(nameav);
860
861 for (offset = AvFILLp(nameav); offset > 0; offset--) {
862 const SV * const namesv = name_svp[offset];
863 if (namesv && namesv != &PL_sv_undef
864 && strEQ(SvPVX_const(namesv), name))
865 {
866 if (SvFAKE(namesv)) {
867 fake_offset = offset; /* in case we don't find a real one */
868 continue;
869 }
870 /* is seq within the range _LOW to _HIGH ?
871 * This is complicated by the fact that PL_cop_seqmax
872 * may have wrapped around at some point */
873 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
874 continue; /* not yet introduced */
875
876 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
877 /* in compiling scope */
878 if (
879 (seq > COP_SEQ_RANGE_LOW(namesv))
880 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
881 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
882 )
883 break;
884 }
885 else if (
886 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
887 ?
888 ( seq > COP_SEQ_RANGE_LOW(namesv)
889 || seq <= COP_SEQ_RANGE_HIGH(namesv))
890
891 : ( seq > COP_SEQ_RANGE_LOW(namesv)
892 && seq <= COP_SEQ_RANGE_HIGH(namesv))
893 )
894 break;
895 }
896 }
897
898 if (offset > 0 || fake_offset > 0 ) { /* a match! */
899 if (offset > 0) { /* not fake */
900 fake_offset = 0;
901 *out_name_sv = name_svp[offset]; /* return the namesv */
902
903 /* set PAD_FAKELEX_MULTI if this lex can have multiple
904 * instances. For now, we just test !CvUNIQUE(cv), but
905 * ideally, we should detect my's declared within loops
906 * etc - this would allow a wider range of 'not stayed
907 * shared' warnings. We also treated already-compiled
908 * lexes as not multi as viewed from evals. */
909
910 *out_flags = CvANON(cv) ?
911 PAD_FAKELEX_ANON :
912 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
913 ? PAD_FAKELEX_MULTI : 0;
914
915 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
916 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
917 PTR2UV(cv), (long)offset,
918 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
919 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
920 }
921 else { /* fake match */
922 offset = fake_offset;
923 *out_name_sv = name_svp[offset]; /* return the namesv */
924 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
925 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
926 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
927 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
928 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
929 ));
930 }
931
932 /* return the lex? */
933
934 if (out_capture) {
935
936 /* our ? */
937 if (SvPAD_OUR(*out_name_sv)) {
938 *out_capture = NULL;
939 return offset;
940 }
941
942 /* trying to capture from an anon prototype? */
943 if (CvCOMPILED(cv)
944 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
945 : *out_flags & PAD_FAKELEX_ANON)
946 {
947 if (warn)
948 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
949 "Variable \"%s\" is not available", name);
950 *out_capture = NULL;
951 }
952
953 /* real value */
954 else {
955 int newwarn = warn;
956 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
957 && !SvPAD_STATE(name_svp[offset])
958 && warn && ckWARN(WARN_CLOSURE)) {
959 newwarn = 0;
960 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
961 "Variable \"%s\" will not stay shared", name);
962 }
963
964 if (fake_offset && CvANON(cv)
965 && CvCLONE(cv) &&!CvCLONED(cv))
966 {
967 SV *n;
968 /* not yet caught - look further up */
969 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
970 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
971 PTR2UV(cv)));
972 n = *out_name_sv;
973 (void) pad_findlex(name, CvOUTSIDE(cv),
974 CvOUTSIDE_SEQ(cv),
975 newwarn, out_capture, out_name_sv, out_flags);
976 *out_name_sv = n;
977 return offset;
978 }
979
980 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
981 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
982 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
983 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
984 PTR2UV(cv), PTR2UV(*out_capture)));
985
986 if (SvPADSTALE(*out_capture)
987 && !SvPAD_STATE(name_svp[offset]))
988 {
989 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
990 "Variable \"%s\" is not available", name);
991 *out_capture = NULL;
992 }
993 }
994 if (!*out_capture) {
995 if (*name == '#')
996 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
997 else if (*name == '%')
998 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
999 else
1000 *out_capture = sv_newmortal();
1001 }
1002 }
1003
1004 return offset;
1005 }
1006 }
1007
1008 /* it's not in this pad - try above */
1009
1010 if (!CvOUTSIDE(cv))
1011 return NOT_IN_PAD;
1012
1013 /* out_capture non-null means caller wants us to capture lex; in
1014 * addition we capture ourselves unless it's an ANON/format */
1015 new_capturep = out_capture ? out_capture :
1016 CvLATE(cv) ? NULL : &new_capture;
1017
1018 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1019 new_capturep, out_name_sv, out_flags);
1020 if ((PADOFFSET)offset == NOT_IN_PAD)
1021 return NOT_IN_PAD;
1022
1023 /* found in an outer CV. Add appropriate fake entry to this pad */
1024
1025 /* don't add new fake entries (via eval) to CVs that we have already
1026 * finished compiling, or to undef CVs */
1027 if (CvCOMPILED(cv) || !padlist)
1028 return 0; /* this dummy (and invalid) value isnt used by the caller */
1029
1030 {
1031 /* This relies on sv_setsv_flags() upgrading the destination to the same
1032 type as the source, independent of the flags set, and on it being
1033 "good" and only copying flag bits and pointers that it understands.
1034 */
1035 SV *new_namesv = newSVsv(*out_name_sv);
1036 AV * const ocomppad_name = PL_comppad_name;
1037 PAD * const ocomppad = PL_comppad;
1038 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1039 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1040 PL_curpad = AvARRAY(PL_comppad);
1041
1042 new_offset
1043 = pad_add_name_sv(new_namesv,
1044 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1045 SvPAD_TYPED(*out_name_sv)
1046 ? SvSTASH(*out_name_sv) : NULL,
1047 SvOURSTASH(*out_name_sv)
1048 );
1049
1050 SvFAKE_on(new_namesv);
1051 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1052 "Pad addname: %ld \"%.*s\" FAKE\n",
1053 (long)new_offset,
1054 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1055 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1056
1057 PARENT_PAD_INDEX_set(new_namesv, 0);
1058 if (SvPAD_OUR(new_namesv)) {
1059 NOOP; /* do nothing */
1060 }
1061 else if (CvLATE(cv)) {
1062 /* delayed creation - just note the offset within parent pad */
1063 PARENT_PAD_INDEX_set(new_namesv, offset);
1064 CvCLONE_on(cv);
1065 }
1066 else {
1067 /* immediate creation - capture outer value right now */
1068 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1069 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1070 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1071 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1072 }
1073 *out_name_sv = new_namesv;
1074 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1075
1076 PL_comppad_name = ocomppad_name;
1077 PL_comppad = ocomppad;
1078 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1079 }
1080 return new_offset;
1081 }
It seems it has to do with if the containing pad is held within a CV or not, but I am not sure of the exact specifics.