/* maps to mod_mime_magic::apprentice */ static int fmm_parse_magic_file(PerlFMM *state, char *file) { int ws_offset; int lineno; int errs; /* char line[BUFSIZ + 1];*/ PerlIO *fhandle; SV *err; SV *sv = sv_2mortal(newSV(BUFSIZ)); SV *PL_rs_orig = newSVsv(PL_rs); char *line; fhandle = PerlIO_open(file, "r"); if (! fhandle) { err = newSVpvf( "Failed to open %s: %s", file, strerror(errno)); FMM_SET_ERROR(state, err); PerlIO_close(fhandle); return -1; } /* * Parse it line by line * $/ (slurp mode) is needed here */ PL_rs = sv_2mortal(newSVpvn("\n", 1)); for(lineno = 1; sv_gets(sv, fhandle, 0) != NULL; lineno++) { line = SvPV_nolen(sv); /* delete newline */ if (line[0]) { line[strlen(line) - 1] = '\0'; } /* skip leading whitespace */ ws_offset = 0; while (line[ws_offset] && isSPACE(line[ws_offset])) { ws_offset++; } /* skip blank lines */ if (line[ws_offset] == 0) { continue; } if (line[ws_offset] == '#') { continue; } if (fmm_parse_magic_line(state, line, lineno) != 0) { ++errs; } } PerlIO_close(fhandle); PL_rs = PL_rs_orig; return 1; }
/* maxlen 0 = read one text line */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { filter_t funcp; SV *datasv = NULL; if (!PL_rsfp_filters) return -1; if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); if (maxlen) { /* Want a block */ int len ; const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ if (PerlIO_error(PL_rsfp)) return -1; /* error */ else return 0 ; /* end of file */ } SvCUR_set(buf_sv, old_len + len) ; } else { /* Want a line */ if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) { if (PerlIO_error(PL_rsfp)) return -1; /* error */ else return 0 ; /* end of file */ } } return SvCUR(buf_sv); } /* Skip this filter slot if filter has been deleted */ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) { DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: skipped (filter deleted)\n", idx)); return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", idx, datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ return (*funcp)(aTHX_ idx, buf_sv, maxlen); }
STATIC char * S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) { #ifdef PERL_CR_FILTER if (!PL_rsfp_filters) { filter_add(S_cr_textfilter,NULL); } #endif if (PL_rsfp_filters) { if (!append) SvCUR_set(sv, 0); /* start with empty line */ if (FILTER_READ(0, sv, 0) > 0) return ( SvPVX(sv) ) ; else return Nullch ; } else return (sv_gets(sv, fp, append)); }
OP * Perl_do_readline(pTHX_ GV* gv) { dVAR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; register IO * const io = GvIO(gv); register const I32 type = PL_op->op_type; const I32 gimme = GIMME_V; PERL_ARGS_ASSERT_DO_READLINE; fp = NULL; if (io) { fp = IoIFP(io); if (!fp) { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { IoLINES(io) = 0; if (av_len(GvAVn(gv)) < 0) { IoFLAGS(io) &= ~IOf_START; do_openn(io,"-",1,FALSE,O_RDONLY,0,NULL,NULL,0); sv_setpvn(GvSVn(gv), "-", 1); SvSETMAGIC(GvSV(gv)); fp = IoIFP(io); goto have_fp; } } fp = nextargv(gv); if (!fp) { /* Note: fp != IoIFP(io) */ (void)do_close(gv, FALSE); /* now it does*/ } } } else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { report_evil_fh(io, OP_phoney_OUTPUT_ONLY); } } if (!fp) { if ((!io || !(IoFLAGS(io) & IOf_START)) && ckWARN2(WARN_GLOB, WARN_CLOSED)) { if (type == OP_GLOB) Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", Strerror(errno)); else report_evil_fh(io, PL_op->op_type); } if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); if ( ! SvPVOK(TARG) ) sv_upgrade(TARG, SVt_PV); SvOK_off(TARG); } PUSHTARG; } RETURN; } have_fp: if (gimme == G_SCALAR) { sv = TARG; if (type == OP_RCATLINE) { NOOP; } else { if ( SvOK(sv) && ! SvPVOK(sv) ) sv_clear_body(sv); } if (SvROK(sv)) { if (type == OP_RCATLINE) SvPV_force_nolen(sv); else sv_unref(sv); } else if (isGV_with_GP(sv)) { SvPV_force_nolen(sv); } SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen && !SvREADONLY(sv)) Sv_Grow(sv, 80); /* try short-buffering it */ offset = 0; if (type == OP_RCATLINE && SvOK(sv)) { if (!SvPOK(sv)) { SvPV_force_nolen(sv); } offset = SvCUR(sv); } } else { sv = sv_2mortal(newSV(80)); offset = 0; } /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv) || PerlIO_error(fp))) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { fp = nextargv(gv); if (fp) continue; (void)do_close(gv, FALSE); } else if (type == OP_GLOB) { if (!do_close(gv, FALSE) && ckWARN(WARN_GLOB)) { Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (child exited with status %d%s)", (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); SvOK_off(TARG); } SPAGAIN; PUSHTARG; } RETURN; }