Net-Pcap-0.21/0000755000175000017500000000000014362166275012423 5ustar corioncorionNet-Pcap-0.21/MANIFEST.SKIP0000644000175000017500000000044714362166261014321 0ustar corioncorion^\.git\/ maint ^tags$ .last_cover_stats .travis.yml .appveyor.yml ^\.github Makefile$ ^blib ^pm_to_blib ^.*\.bak ^.*\.old ^.*\.o ^.*\.bs ^.*\.exe ^const-c.inc ^const-xs.inc ^Pcap.c ^t.*sessions ^\.prove ^.*\.log ^.*\.swp$ ^MYMETA ^.releaserc ^.*\.cmd ^Net-Pcap ^funcs.txt ^macros.all ^wpcap.def Net-Pcap-0.21/Pcap.xs0000644000175000017500000005734114362166261013667 0ustar corioncorion/* * Pcap.xs * * XS wrapper for LBL pcap(3) library. * * Copyright (C) 2005, 2006, 2007, 2008, 2009 Sebastien Aperghis-Tramoni * with some code contributed by Jean-Louis Morel. All rights reserved. * Copyright (C) 2003 Marco Carnut. All rights reserved. * Copyright (C) 1999 Tim Potter. All rights reserved. * * This program is free software; you can redistribute it and/or modify it * under the same terms as Perl itself. * */ #ifdef __cplusplus extern "C" { #endif #ifdef _CYGWIN #include #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define NEED_PL_signals 1 #define NEED_sv_2pv_nolen 1 #include "ppport.h" #include #ifdef _CYGWIN #include #endif /* Perl specific constants */ #define PERL_SIGNALS_SAFE 0x00010000 #define PERL_SIGNALS_UNSAFE 0x00010001 #include "const-c.inc" #include "stubs.inc" #ifdef __cplusplus } #endif typedef struct bpf_program pcap_bpf_program_t; /* A struct for holding the user context and callback information*/ typedef struct User_Callback { SV *callback_fn; SV *user; } User_Callback; /* Wrapper for callback function */ void callback_wrapper(u_char *user, const struct pcap_pkthdr *h, const u_char *pkt) { SV *packet = newSVpvn((char *)pkt, h->caplen); HV *hdr = newHV(); SV *ref_hdr = newRV_inc((SV*)hdr); User_Callback* user_callback = (User_Callback*) user; /* Fill the hash fields */ hv_store(hdr, "tv_sec", strlen("tv_sec"), newSViv(h->ts.tv_sec), 0); hv_store(hdr, "tv_usec", strlen("tv_usec"), newSViv(h->ts.tv_usec), 0); hv_store(hdr, "caplen", strlen("caplen"), newSVuv(h->caplen), 0); hv_store(hdr, "len", strlen("len"), newSVuv(h->len), 0); /* Push arguments onto stack */ dSP; PUSHMARK(sp); XPUSHs((SV*)user_callback->user); XPUSHs(ref_hdr); XPUSHs(packet); PUTBACK; /* Call perl function */ call_sv (user_callback->callback_fn, G_DISCARD); /* Decrement refcount to temp SVs */ SvREFCNT_dec(packet); SvREFCNT_dec(hdr); SvREFCNT_dec(ref_hdr); } MODULE = Net::Pcap PACKAGE = Net::Pcap PREFIX = pcap_ INCLUDE: const-xs.inc PROTOTYPES: DISABLE char * pcap_lookupdev(err) SV *err CODE: if (SvROK(err)) { char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_lookupdev(errbuf); #ifdef WPCAP { /* Conversion from Windows Unicode (UCS-2) to ANSI */ int size = lstrlenW((PWSTR)RETVAL) + 2; char *str = NULL; Newx(str, size, char); WideCharToMultiByte(CP_ACP, 0, (PWSTR)RETVAL, -1, str, size, NULL, NULL); lstrcpyA(RETVAL, str); Safefree(str); } #endif /* WPCAP */ if (RETVAL == NULL) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg1 not a hash ref"); OUTPUT: RETVAL err int pcap_lookupnet(device, net, mask, err) const char *device SV *net SV *mask SV *err CODE: if (SvROK(net) && SvROK(mask) && SvROK(err)) { bpf_u_int32 netp, maskp; char *errbuf = NULL; SV *net_sv = SvRV(net); SV *mask_sv = SvRV(mask); SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_lookupnet(device, &netp, &maskp, errbuf); netp = ntohl(netp); maskp = ntohl(maskp); if (RETVAL != -1) { sv_setuv(net_sv, netp); sv_setuv(mask_sv, maskp); err_sv = &PL_sv_undef; } else { sv_setpv(err_sv, errbuf); } safefree(errbuf); } else { RETVAL = -1; if (!SvROK(net )) croak("arg2 not a reference"); if (!SvROK(mask)) croak("arg3 not a reference"); if (!SvROK(err )) croak("arg4 not a reference"); } OUTPUT: net mask err RETVAL void pcap_findalldevs_xs(devinfo, err) SV * devinfo SV * err PREINIT: char *errbuf = NULL; Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); PPCODE: if ( SvROK(err) && SvROK(devinfo) && (SvTYPE(SvRV(devinfo)) == SVt_PVHV) ) { int r; pcap_if_t *alldevs, *d; HV *hv; SV *err_sv = SvRV(err); hv = (HV *)SvRV(devinfo); r = pcap_findalldevs(&alldevs, errbuf); switch(r) { case 0: /* normal case */ for (d=alldevs; d; d=d->next) { XPUSHs(sv_2mortal(newSVpv(d->name, 0))); if (d->description) hv_store(hv, d->name, strlen(d->name), newSVpv(d->description, 0), 0); else if ( (strcmp(d->name,"lo") == 0) || (strcmp(d->name,"lo0") == 0)) hv_store(hv, d->name, strlen(d->name), newSVpv("Loopback device", 0), 0); else hv_store(hv, d->name, strlen(d->name), newSVpv("No description available", 0), 0); } pcap_freealldevs(alldevs); err_sv = &PL_sv_undef; break; case 3: { /* function is not available */ char *dev = pcap_lookupdev(errbuf); if (dev == NULL) { sv_setpv(err_sv, errbuf); break; } XPUSHs(sv_2mortal(newSVpv(dev, 0))); if ( (strcmp(dev,"lo") == 0) || (strcmp(dev,"lo0") == 0)) hv_store(hv, dev, strlen(dev), newSVpv("", 0), 0); else hv_store(hv, dev, strlen(dev), newSVpv("No description available", 0), 0); break; } case -1: /* error */ sv_setpv(err_sv, errbuf); break; } } else { if ( !SvROK(devinfo) || (SvTYPE(SvRV(devinfo)) != SVt_PVHV) ) croak("arg1 not a hash ref"); if ( !SvROK(err) ) croak("arg2 not a scalar ref"); } safefree(errbuf); pcap_t * pcap_open_live(device, snaplen, promisc, to_ms, err) const char *device int snaplen int promisc int to_ms SV *err; CODE: if (SvROK(err)) { char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); #ifdef _MSC_VER /* Net::Pcap hangs when to_ms == 0 under ActivePerl/MSVC */ if (to_ms == 0) to_ms = 1; #endif RETVAL = pcap_open_live(device, snaplen, promisc, to_ms, errbuf); if (RETVAL == NULL) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg5 not a reference"); OUTPUT: err RETVAL pcap_t * pcap_open_dead(linktype, snaplen) int linktype int snaplen OUTPUT: RETVAL pcap_t * pcap_open_offline(fname, err) const char *fname SV *err CODE: if (SvROK(err)) { char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_open_offline(fname, errbuf); if (RETVAL == NULL) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg2 not a reference"); OUTPUT: err RETVAL pcap_dumper_t * pcap_dump_open(p, fname) pcap_t *p const char *fname int pcap_setnonblock(p, nb, err) pcap_t *p int nb SV *err CODE: if (SvROK(err)) { char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_setnonblock(p, nb, errbuf); if (RETVAL == -1) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg3 not a reference"); OUTPUT: err RETVAL int pcap_getnonblock(p, err) pcap_t *p SV *err CODE: if (SvROK(err)) { char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_getnonblock(p, errbuf); if (RETVAL == -1) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg2 not a reference"); OUTPUT: err RETVAL int pcap_dispatch(p, cnt, callback, user) pcap_t *p int cnt SV *callback SV *user CODE: User_Callback user_callback; { user_callback.callback_fn = newSVsv(callback); user_callback.user = newSVsv(user); *(pcap_geterr(p)) = '\0'; /* reset error string */ RETVAL = pcap_dispatch(p, cnt, callback_wrapper, (u_char *)&user_callback); SvREFCNT_dec(user_callback.user); SvREFCNT_dec(user_callback.callback_fn); } OUTPUT: RETVAL int pcap_loop(p, cnt, callback, user) pcap_t *p int cnt SV *callback SV *user CODE: User_Callback user_callback; { user_callback.callback_fn = newSVsv(callback); user_callback.user = newSVsv(user); RETVAL = pcap_loop(p, cnt, callback_wrapper, (u_char *)&user_callback); SvREFCNT_dec(user_callback.user); SvREFCNT_dec(user_callback.callback_fn); } OUTPUT: RETVAL SV * pcap_next(p, pkt_header) pcap_t *p SV *pkt_header CODE: if (SvROK(pkt_header) && (SvTYPE(SvRV(pkt_header)) == SVt_PVHV)) { struct pcap_pkthdr real_h; const u_char *result; HV *hv; memset(&real_h, '\0', sizeof(real_h)); result = pcap_next(p, &real_h); hv = (HV *)SvRV(pkt_header); if (result != NULL) { hv_store(hv, "tv_sec", strlen("tv_sec"), newSViv(real_h.ts.tv_sec), 0); hv_store(hv, "tv_usec", strlen("tv_usec"), newSViv(real_h.ts.tv_usec), 0); hv_store(hv, "caplen", strlen("caplen"), newSVuv(real_h.caplen), 0); hv_store(hv, "len", strlen("len"), newSVuv(real_h.len), 0); RETVAL = newSVpv((char *)result, real_h.caplen); } else RETVAL = &PL_sv_undef; } else croak("arg2 not a hash ref"); OUTPUT: pkt_header RETVAL int pcap_next_ex(p, pkt_header, pkt_data) pcap_t *p SV *pkt_header SV *pkt_data CODE: /* Check if pkt_header is a hashref and pkt_data a scalarref */ if (SvROK(pkt_header) && (SvTYPE(SvRV(pkt_header)) == SVt_PVHV) && SvROK(pkt_data)) { struct pcap_pkthdr *header; const u_char *data; HV *hv; memset(&header, '\0', sizeof(header)); RETVAL = pcap_next_ex(p, &header, &data); hv = (HV *)SvRV(pkt_header); if (RETVAL == 1) { hv_store(hv, "tv_sec", strlen("tv_sec"), newSViv(header->ts.tv_sec), 0); hv_store(hv, "tv_usec", strlen("tv_usec"), newSViv(header->ts.tv_usec), 0); hv_store(hv, "caplen", strlen("caplen"), newSVuv(header->caplen), 0); hv_store(hv, "len", strlen("len"), newSVuv(header->len), 0); sv_setpvn((SV *)SvRV(pkt_data), (char *) data, header->caplen); } } else { RETVAL = -1; if (!SvROK(pkt_header) || (SvTYPE(SvRV(pkt_header)) != SVt_PVHV)) croak("arg2 not a hash ref"); if (!SvROK(pkt_data)) croak("arg3 not a scalar ref"); } OUTPUT: pkt_header pkt_data RETVAL void pcap_dump(p, pkt_header, sp) pcap_dumper_t *p SV *pkt_header SV *sp CODE: /* Check if pkt_header is a hashref */ if (SvROK(pkt_header) && (SvTYPE(SvRV(pkt_header)) == SVt_PVHV)) { struct pcap_pkthdr real_h; char *real_sp; HV *hv; SV **sv; memset(&real_h, '\0', sizeof(real_h)); /* Copy from hash to pcap_pkthdr */ hv = (HV *)SvRV(pkt_header); sv = hv_fetch(hv, "tv_sec", strlen("tv_sec"), 0); if (sv != NULL) { real_h.ts.tv_sec = SvIV(*sv); } sv = hv_fetch(hv, "tv_usec", strlen("tv_usec"), 0); if (sv != NULL) { real_h.ts.tv_usec = SvIV(*sv); } sv = hv_fetch(hv, "caplen", strlen("caplen"), 0); if (sv != NULL) { real_h.caplen = SvIV(*sv); } sv = hv_fetch(hv, "len", strlen("len"), 0); if (sv != NULL) { real_h.len = SvIV(*sv); } real_sp = SvPV(sp, PL_na); /* Call pcap_dump() */ pcap_dump((u_char *)p, &real_h, (u_char *)real_sp); } else croak("arg2 not a hash ref"); int pcap_compile(p, fp, str, optimize, mask) pcap_t *p SV *fp char *str int optimize bpf_u_int32 mask CODE: if (SvROK(fp)) { pcap_bpf_program_t *real_fp = NULL; Newx(real_fp, 1, pcap_bpf_program_t); *(pcap_geterr(p)) = '\0'; /* reset error string */ RETVAL = pcap_compile(p, real_fp, str, optimize, mask); sv_setref_pv(SvRV(fp), "pcap_bpf_program_tPtr", (void *)real_fp); } else croak("arg2 not a reference"); OUTPUT: fp RETVAL int pcap_compile_nopcap(snaplen, linktype, fp, str, optimize, mask) int snaplen int linktype SV *fp char *str int optimize bpf_u_int32 mask CODE: if (SvROK(fp)) { pcap_bpf_program_t *real_fp = NULL; Newx(real_fp, 1, pcap_bpf_program_t); RETVAL = pcap_compile_nopcap(snaplen, linktype, real_fp, str, optimize, mask); sv_setref_pv(SvRV(fp), "pcap_bpf_program_tPtr", (void *)real_fp); } else croak("arg3 not a reference"); OUTPUT: fp RETVAL int pcap_offline_filter(fp, header, p) pcap_bpf_program_t *fp SV *header SV *p CODE: /* Check that header is a hashref */ if (SvROK(header) && (SvTYPE(SvRV(header)) == SVt_PVHV)) { struct pcap_pkthdr real_h; char *real_p; HV *hv; SV **sv; memset(&real_h, '\0', sizeof(real_h)); /* Copy from hash to pcap_pkthdr */ hv = (HV *)SvRV(header); sv = hv_fetch(hv, "tv_sec", strlen("tv_sec"), 0); if (sv != NULL) { real_h.ts.tv_sec = SvIV(*sv); } sv = hv_fetch(hv, "tv_usec", strlen("tv_usec"), 0); if (sv != NULL) { real_h.ts.tv_usec = SvIV(*sv); } sv = hv_fetch(hv, "caplen", strlen("caplen"), 0); if (sv != NULL) { real_h.caplen = SvIV(*sv); } sv = hv_fetch(hv, "len", strlen("len"), 0); if (sv != NULL) { real_h.len = SvIV(*sv); } real_p = SvPV(p, PL_na); RETVAL = pcap_offline_filter(fp, &real_h, (unsigned char *) real_p); } else croak("arg2 not a hash ref"); OUTPUT: RETVAL int pcap_setfilter(p, fp) pcap_t *p pcap_bpf_program_t *fp void pcap_freecode(fp) pcap_bpf_program_t *fp void pcap_breakloop(p) pcap_t *p void pcap_close(p) pcap_t *p void pcap_dump_close(p) pcap_dumper_t *p FILE * pcap_dump_file(p) pcap_dumper_t *p int pcap_dump_flush(p) pcap_dumper_t *p int pcap_datalink(p) pcap_t *p int pcap_set_datalink(p, linktype) pcap_t *p int linktype int pcap_datalink_name_to_val(name) const char *name const char * pcap_datalink_val_to_name(linktype) int linktype const char * pcap_datalink_val_to_description(linktype) int linktype int pcap_snapshot(p) pcap_t *p int pcap_is_swapped(p) pcap_t *p int pcap_major_version(p) pcap_t *p int pcap_minor_version(p) pcap_t *p void pcap_perror(p, prefix) pcap_t *p char *prefix char * pcap_geterr(p) pcap_t *p char * pcap_strerror(error) int error const char * pcap_lib_version() SV * pcap_perl_settings(setting) int setting CODE: RETVAL = 0; switch (setting) { case PERL_SIGNALS_SAFE: RETVAL = newSVuv(PL_signals); PL_signals = 0; break; case PERL_SIGNALS_UNSAFE: RETVAL = newSVuv(PL_signals); PL_signals = PERL_SIGNALS_UNSAFE_FLAG; break; } OUTPUT: RETVAL FILE * pcap_file(p) pcap_t *p int pcap_fileno(p) pcap_t *p int pcap_get_selectable_fd(p) pcap_t *p int pcap_stats(p, ps) pcap_t *p; SV *ps; CODE: /* Call pcap_stats() function */ if (SvROK(ps) && (SvTYPE(SvRV(ps)) == SVt_PVHV)) { struct pcap_stat real_ps; HV *hv; *(pcap_geterr(p)) = '\0'; /* reset error string */ RETVAL = pcap_stats(p, &real_ps); /* Copy pcap_stats fields into hash */ hv = (HV *)SvRV(ps); hv_store(hv, "ps_recv", strlen("ps_recv"), newSVuv(real_ps.ps_recv), 0); hv_store(hv, "ps_drop", strlen("ps_drop"), newSVuv(real_ps.ps_drop), 0); hv_store(hv, "ps_ifdrop", strlen("ps_ifdrop"), newSVuv(real_ps.ps_ifdrop), 0); } else croak("arg2 not a hash ref"); OUTPUT: RETVAL int pcap_createsrcstr(source, type, host, port, name, err) SV * source int type char * host char * port char * name SV * err CODE: if (SvROK(source) && SvROK(err)) { char *errbuf = NULL; char *sourcebuf = NULL; SV *err_sv = SvRV(err); SV *source_sv = SvRV(source); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); Newx(sourcebuf, PCAP_BUF_SIZE+1, char); RETVAL = pcap_createsrcstr(sourcebuf, type, host, port, name, errbuf); if (RETVAL != -1) { sv_setpv(source_sv, sourcebuf); err_sv = &PL_sv_undef; } else { sv_setpv(err_sv, errbuf); } safefree(errbuf); safefree(sourcebuf); } else { RETVAL = -1; if (!SvROK(source)) croak("arg1 not a reference"); if (!SvROK(err)) croak("arg6 not a reference"); } OUTPUT: source err RETVAL int pcap_parsesrcstr(source, type, host, port, name, err) char * source SV * type SV * host SV * port SV * name SV * err CODE: if ( !SvROK(type) ) croak("arg2 not a reference"); if ( !SvROK(host) ) croak("arg3 not a reference"); if ( !SvROK(port) ) croak("arg4 not a reference"); if ( !SvROK(name) ) croak("arg5 not a reference"); if ( !SvROK(err ) ) croak("arg6 not a reference"); else { int rtype; char *hostbuf = NULL; char *portbuf = NULL; char *namebuf = NULL; char *errbuf = NULL; SV *type_sv = SvRV(type); SV *host_sv = SvRV(host); SV *port_sv = SvRV(port); SV *name_sv = SvRV(name); SV *err_sv = SvRV(err); Newx(hostbuf, PCAP_BUF_SIZE+1, char); Newx(portbuf, PCAP_BUF_SIZE+1, char); Newx(namebuf, PCAP_BUF_SIZE+1, char); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); RETVAL = pcap_parsesrcstr(source, &rtype, hostbuf, portbuf, namebuf, errbuf); if (RETVAL != -1) { sv_setiv(type_sv, rtype); sv_setpv(host_sv, hostbuf); sv_setpv(port_sv, portbuf); sv_setpv(name_sv, namebuf); err_sv = &PL_sv_undef; } else { sv_setpv(err_sv, errbuf); } safefree(hostbuf); safefree(portbuf); safefree(namebuf); safefree(errbuf); } OUTPUT: type host port name err RETVAL pcap_t * pcap_open(source, snaplen, flags, read_timeout, auth, err) char *source int snaplen int flags int read_timeout SV *auth SV *err CODE: if (!SvROK(err)) croak("arg6 not a reference"); if ( !SvOK(auth) || (SvOK(auth) && SvROK(auth) && (SvTYPE(SvRV(auth)) == SVt_PVHV)) ) { struct pcap_rmtauth real_auth; struct pcap_rmtauth *preal_auth; char *errbuf = NULL; SV *err_sv = SvRV(err); Newx(errbuf, PCAP_ERRBUF_SIZE+1, char); if (!SvOK(auth)) { /* if auth (struct pcap_rmtauth) is undef */ preal_auth = NULL; } else { /* auth (struct pcap_rmtauth) is a hashref */ HV *hv; SV **sv; memset(&real_auth, '\0', sizeof(real_auth)); /* Copy from hash to pcap_rmtauth */ hv = (HV *)SvRV(auth); sv = hv_fetch(hv, "type", strlen("type"), 0); if (sv != NULL) real_auth.type = SvIV(*sv); sv = hv_fetch(hv, "username", strlen("username"), 0); if (sv != NULL) real_auth.username = SvPV(*sv, PL_na); sv = hv_fetch(hv, "password", strlen("password"), 0); if (sv != NULL) real_auth.password = SvPV(*sv, PL_na); preal_auth = &real_auth; } RETVAL = pcap_open(source, snaplen, flags, read_timeout, preal_auth, errbuf); if (RETVAL == NULL) { sv_setpv(err_sv, errbuf); } else { err_sv = &PL_sv_undef; } safefree(errbuf); } else croak("arg5 not a hash ref"); OUTPUT: RETVAL err int pcap_setuserbuffer(p, size) pcap_t *p int size int pcap_setbuff(p, dim) pcap_t *p int dim int pcap_setmode (p, mode) pcap_t *p int mode int pcap_setmintocopy(p, size) pcap_t *p int size void pcap_getevent(p) pcap_t *p PREINIT: unsigned int h; PPCODE: h = (unsigned int) pcap_getevent(p); ST(0) = sv_newmortal(); sv_setref_iv(ST(0), "Win32::Event", h); XSRETURN(1); int pcap_sendpacket(p, buf) pcap_t *p SV *buf CODE: RETVAL = pcap_sendpacket(p, (u_char *)SvPVX(buf), sv_len(buf)); OUTPUT: RETVAL pcap_send_queue * pcap_sendqueue_alloc(memsize) u_int memsize MODULE = Net::Pcap PACKAGE = pcap_send_queuePtr void DESTROY(queue) pcap_send_queue * queue CODE: pcap_sendqueue_destroy(queue); MODULE = Net::Pcap PACKAGE = Net::Pcap PREFIX = pcap_ int pcap_sendqueue_queue(queue, header, p) pcap_send_queue * queue SV *header SV *p CODE: /* Check that header is a hashref */ if (SvROK(header) && (SvTYPE(SvRV(header)) == SVt_PVHV)) { struct pcap_pkthdr real_h; char *real_p; HV *hv; SV **sv; memset(&real_h, '\0', sizeof(real_h)); /* Copy from hash to pcap_pkthdr */ hv = (HV *)SvRV(header); sv = hv_fetch(hv, "tv_sec", strlen("tv_sec"), 0); if (sv != NULL) { real_h.ts.tv_sec = SvIV(*sv); } sv = hv_fetch(hv, "tv_usec", strlen("tv_usec"), 0); if (sv != NULL) { real_h.ts.tv_usec = SvIV(*sv); } sv = hv_fetch(hv, "caplen", strlen("caplen"), 0); if (sv != NULL) { real_h.caplen = SvIV(*sv); } sv = hv_fetch(hv, "len", strlen("len"), 0); if (sv != NULL) { real_h.len = SvIV(*sv); } real_p = SvPV(p, PL_na); /* Call pcap_sendqueue_queue() */ RETVAL = pcap_sendqueue_queue(queue, &real_h, (unsigned char *) real_p); } else croak("arg2 not a hash ref"); OUTPUT: RETVAL u_int pcap_sendqueue_transmit(p, queue, sync) pcap_t *p pcap_send_queue * queue int sync Net-Pcap-0.21/Makefile.PL0000644000175000017500000004472214362166261014401 0ustar corioncorionuse strict; use Config; use Cwd; use ExtUtils::MakeMaker; eval "use ExtUtils::MakeMaker::Coverage"; use File::Spec; my ($DEBUG, %options, $DEVNULL, $is_Win32, $has_Win32); if ($^O eq 'MSWin32') { $options{LIBS} = '-lwpcap'; $options{DEFINE} = '-DWINSOCK2_H_REQUESTED -DWPCAP -DHAVE_REMOTE'; # patch ActivePerl CORE/sys/socket.h win32_sys_socket_patch(); } elsif ($^O eq 'cygwin') { $options{LIBS} = '-lwpcap'; $options{DEFINE} = '-DWPCAP -D_CYGWIN -DWIN32'; cygwin_pcap_headers(); } else { $options{CCFLAGS} = "$Config{ccflags} -Wall -Wwrite-strings" if $Config{ccname} eq "gcc" and $] >= 5.006; $options{LIBS} = '-lpcap'; } for my $arg (@ARGV) { my($key,$val) = split /=/, $arg, 2; $options{$key} = length $options{$key} ? "$val $options{$key}" : $val; } # The detection logic is: # 1. first try to check if the pcap library is available; # 2. then try to use the pcap_lib_version() function which is present # in recent version and is the only function that can be called # with no argument. if ($has_Win32) { # ActivePerl, Cygwin die <<"REASON" unless have_library('wpcap', 'blank', 'pcap'); - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The WinPcap driver is not installed on this machine. \a Please get and install the WinPcap driver and DLLs (auto-installer) from http://www.winpcap.org/install/ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REASON die <<"REASON" unless have_library('wpcap', 'pcap_lib_version', 'pcap'); - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - You appear to lack the WinPcap developer pack. \a If it is installed in a non-standard location, please try setting the LIBS and INC values on the command line. For instance, if you have unziped the developer's pack in C:\\WpdPack, you should execute: perl Makefile.PL INC=-IC:/WpdPack/Include "LIBS=-LC:/WpdPack/Lib -lwpcap" Or get and install the WinPcap developer's pack from http://www.winpcap.org/install/ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REASON } else { # other systems (Unix) die <<"REASON" unless have_library('pcap'); - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - You appear to lack the pcap(3) library. \a If it is installed in a non-standard location, please try setting the LIBS and INC values on the command line. Or get the sources and install the pcap library from http://www.tcpdump.org/ If you install the pcap library using a system package, make sure to also install the corresponding -devel package, which contains the C headers needed to compile this module. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REASON die <<"REASON" unless have_library('pcap', 'pcap_lib_version'); - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - You appear to have an old version of the pcap library. \a This module need a recent version of the pcap library in order to provide access to all its features. You can still compile it with your old pcap library but some functions won't be available, and trying to use them in Perl programs will generate errors. Programs only using the old functions should perform as previously. If not, don't hesitate to fill a bug. You can get the latest sources of the pcap library at http://www.tcpdump.org/ If you install the pcap library using a system package, make sure to also install the corresponding -devel package, which contains the C headers needed to compile this module. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REASON } # Now trying to detect which functions are actually available. # We have to do this because the pcap library still doesn't have any macro # to identify its API version and the pcap_lib_version() is only available # since version 0.8 or so. Therefore we add defines in order to replace # missing functions with croaking stubs. # We also store the list of available functions in a file for skipping the # corresponding tests. my @funcs = have_functions(find_functions()); # Get the version of the pcap library, hoping that we have a libpcap # more recent than 0.8: my $pcap_version; # this should come from %ENV or the command line $pcap_version //= get_pcap_version(); $pcap_version =~ m!(\d+\.\S+)! or warn "Couldn't determine version number from [$pcap_version]"; my $pcap_version_number = $1 || '1.8.0'; # a guess # Expand the numbers with leading zeroes for easy stringy comparison $pcap_version_number =~ s!(\d+)!sprintf '%03d', $1!ge; $pcap_version_number =~ s!\.!!g; if( $pcap_version_number > 1009000 ) { # 1.9.0 adds pcap_setsampling() $options{DEFINE} .= ' -DHAVE_PCAP_SETSAMPLING'; } $options{DEFINE} .= cpp_defines(@funcs); # Since PCAP doesn't have a version define, we introduce one: (my $define = $pcap_version_number) =~ s!\.!!; $define =~ s!^0+!!; print "Setting -DPERL_PCAP_VERSION=$define\n"; $options{DEFINE} .= " -DPERL_PCAP_VERSION=$define"; open(FUNCS, '>funcs.txt') or warn "warning: can't write 'funcs.txt': $!\n"; print FUNCS join("\n", @funcs), "\n"; close(FUNCS); WriteMakefile( NAME => 'Net::Pcap', LICENSE => 'perl', AUTHOR => 'Sebastien Aperghis-Tramoni ', DISTNAME => 'Net-Pcap', VERSION_FROM => 'Pcap.pm', ABSTRACT_FROM => 'Pcap.pm', MIN_PERL_VERSION=> 5.6.1, PL_FILES => {}, EXE_FILES => [ 'bin/pcapinfo' ], PREREQ_PM => { # module prereqs 'Carp' => '0', 'XSLoader' => '0', # pcapinfo prereqs 'Sys::Hostname' => '0', # build/test prereqs 'Socket' => '0', 'Test::More' => '0.45', }, META_MERGE => { resources => { repository => "https://github.com/maddingue/Net-Pcap", }, }, dist => { 'COMPRESS' => "gzip -9f", 'SUFFIX' => "gz" }, clean => { FILES => 'Net-Pcap-* macros.all' }, %options, # appropriate CCFLAGS, LDFLAGS and Define's ); if (eval { require ExtUtils::Constant; 1 }) { # If you edit these definitions to change the constants used by this module, # you will need to use the generated const-c.inc and const-xs.inc # files to replace their "fallback" counterparts before distributing your # changes. my @names = (qw( BPF_A BPF_ABS BPF_ADD BPF_ALIGNMENT BPF_ALU BPF_AND BPF_B BPF_DIV BPF_H BPF_IMM BPF_IND BPF_JA BPF_JEQ BPF_JGE BPF_JGT BPF_JMP BPF_JSET BPF_K BPF_LD BPF_LDX BPF_LEN BPF_LSH BPF_MAJOR_VERSION BPF_MAXBUFSIZE BPF_MAXINSNS BPF_MEM BPF_MEMWORDS BPF_MINBUFSIZE BPF_MINOR_VERSION BPF_MISC BPF_MSH BPF_MUL BPF_NEG BPF_OR BPF_RELEASE BPF_RET BPF_RSH BPF_ST BPF_STX BPF_SUB BPF_TAX BPF_TXA BPF_W BPF_X DLT_AIRONET_HEADER DLT_APPLE_IP_OVER_IEEE1394 DLT_ARCNET DLT_ARCNET_LINUX DLT_ATM_CLIP DLT_ATM_RFC1483 DLT_AURORA DLT_AX25 DLT_CHAOS DLT_CHDLC DLT_CISCO_IOS DLT_C_HDLC DLT_DOCSIS DLT_ECONET DLT_EN10MB DLT_EN3MB DLT_ENC DLT_FDDI DLT_FRELAY DLT_HHDLC DLT_IBM_SN DLT_IBM_SP DLT_IEEE802 DLT_IEEE802_11 DLT_IEEE802_11_RADIO DLT_IEEE802_11_RADIO_AVS DLT_IPFILTER DLT_IP_OVER_FC DLT_JUNIPER_ATM1 DLT_JUNIPER_ATM2 DLT_JUNIPER_ES DLT_JUNIPER_GGSN DLT_JUNIPER_MFR DLT_JUNIPER_MLFR DLT_JUNIPER_MLPPP DLT_JUNIPER_MONITOR DLT_JUNIPER_SERVICES DLT_LINUX_IRDA DLT_LINUX_SLL DLT_LOOP DLT_LTALK DLT_NULL DLT_OLD_PFLOG DLT_PCI_EXP DLT_PFLOG DLT_PFSYNC DLT_PPP DLT_PPP_BSDOS DLT_PPP_ETHER DLT_PPP_SERIAL DLT_PRISM_HEADER DLT_PRONET DLT_RAW DLT_RIO DLT_SLIP DLT_SLIP_BSDOS DLT_SUNATM DLT_SYMANTEC_FIREWALL DLT_TZSP DLT_USER0 DLT_USER1 DLT_USER10 DLT_USER11 DLT_USER12 DLT_USER13 DLT_USER14 DLT_USER15 DLT_USER2 DLT_USER3 DLT_USER4 DLT_USER5 DLT_USER6 DLT_USER7 DLT_USER8 DLT_USER9 MODE_CAPT MODE_MON MODE_STAT PCAP_ERRBUF_SIZE PCAP_IF_LOOPBACK PCAP_VERSION_MAJOR PCAP_VERSION_MINOR OPENFLAG_PROMISCUOUS OPENFLAG_DATATX_UDP OPENFLAG_NOCAPTURE_RPCAP RMTAUTH_NULL RMTAUTH_PWD PCAP_SAMP_NOSAMP PCAP_SAMP_FIRST_AFTER_N_MS PCAP_SAMP_1_EVERY_N PCAP_SRC_FILE PCAP_SRC_IFLOCAL PCAP_SRC_IFREMOTE )); ExtUtils::Constant::WriteConstants( NAME => 'pcap', NAMES => \@names, DEFAULT_TYPE => 'IV', C_FILE => 'const-c.inc', XS_FILE => 'const-xs.inc', ); open(MACROS, '>macros.all') or warn "can't write 'macros.all': $!\n"; print MACROS join $/, @names; close(MACROS); } elsif (eval "use File::Copy; 1") { foreach my $file ('const-c.inc', 'const-xs.inc') { my $fallback = File::Spec->catfile('fallback', $file); copy ($fallback, $file) or die "Can't copy $fallback to $file: $!"; } } else { die <<"REASON" - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Your Perl installation lacks both File::Copy and ExtUtils::Constant.\a - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REASON } # The following function patches ActivePerl CORE/sys/socket.h sub win32_sys_socket_patch { my $sockfile; my $ifdef = <<'IFDEF'; /* This file was patched so that WinPcap can use WinSock2. The original file was renamed 'socket.h.orig'. */ #ifdef WINSOCK2_H_REQUESTED #include #else #include #endif /* end of patch */ IFDEF foreach (@INC) { # looking for socket.h if (-e $_.'/CORE/sys/socket.h') { $sockfile = $_.'/CORE/sys/socket.h'; last } } die "file 'socket.h' not found\n" unless $sockfile; open H, "<$sockfile" or die "can't read file '$sockfile': $!\n"; my $h; { local $/; $h = ; } # slurp file close H; if ($h =~ /\#include /) { print "socket.h already patched... ok\n" } else { if (rename $sockfile, $sockfile.'.orig') { $h =~ s/#include /$ifdef/; open H, "> $sockfile" or die $!; print H $h; close H; print "socket.h patched... ok\n" } else { print "Unable to patch socket.h\n" } } } # Cygwin and WinPcap are a *very* special case.. sub cygwin_pcap_headers { my $incdir = ''; my $localinc = File::Spec->catdir(getcwd(), 'include'); for my $i (0..$#ARGV) { if($ARGV[$i] =~ /^INC=/) { (undef,$incdir) = split /-I/, $ARGV[$i], 2; $ARGV[$i] = "INC=-I$localinc"; } } eval 'use File::Path'; mkpath($localinc); eval 'use File::Copy'; for my $file (qw(pcap.h pcap-bpf.h pcap-int.h pcap-stdinc.h Win32-Extensions.h bittypes.h ip6_misc.h)) { my $orig = File::Spec->catfile($incdir, $file); my $dest = File::Spec->catfile($localinc, $file); copy($orig, $dest); } } # The rest of the code, up to the end of this file, has been copied # from XML::LibXML::Common Makefile.PL, then modified in order to # make all this detection stuff works under Win32 ################################################################### # Functions # - these should really be in MakeMaker... But &shrug; ################################################################### use Config; use DynaLoader; use Symbol; BEGIN { eval 'use Win32'; $has_Win32 = !$@; $is_Win32 = ($^O eq 'MSWin32'); if ($is_Win32) { $DEVNULL = 'DEVNULL'; } else { $DEVNULL = eval { File::Spec->devnull }; if ($@) { $DEVNULL = '/dev/null' } } } sub rm_f { my @files = @_; my @realfiles; foreach (@files) { push @realfiles, glob($_); } if (@realfiles) { chmod(0777, @realfiles); unlink(@realfiles); } } sub rm_fr { my @files = @_; my @realfiles; foreach (@files) { push @realfiles, glob($_); } foreach my $file (@realfiles) { if (-d $file) { # warn("$file is a directory\n"); rm_fr("$file/*"); rm_fr("$file/.exists"); rmdir($file) || die "Couldn't remove $file: $!"; } else { # warn("removing $file\n"); chmod(0777, $file); unlink($file); } } } sub xsystem { my $command = shift; if ($DEBUG) { print "\nxsystem: ", $command, "\n"; if (system($command) != 0) { die "system call to '$command' failed"; } return 1; } open(OLDOUT, ">&STDOUT"); open(OLDERR, ">&STDERR"); open(STDOUT, ">$DEVNULL"); open(STDERR, ">$DEVNULL"); my $retval = system($command); open(STDOUT, ">&OLDOUT"); open(STDERR, ">&OLDERR"); die "system call to '$command' failed" if $retval != 0; return 1; } sub backtick { my $command = shift; if ($DEBUG) { print $command, "\n"; my $results = `$command`; chomp $results; die "backticks call to '$command' failed" if $? != 0; return $results; } open(OLDOUT, ">&STDOUT"); open(OLDERR, ">&STDERR"); open(STDOUT, ">$DEVNULL"); open(STDERR, ">$DEVNULL"); my $results = `$command`; my $retval = $?; open(STDOUT, ">&OLDOUT"); open(STDERR, ">&OLDERR"); die "backticks call to '$command' failed" if $retval != 0; chomp $results; return $results; } sub try_link0 { my ($src, $opt) = @_; my $cfile = gensym(); $opt ||= ''; # local $options{LIBS}; # $options{LIBS} .= $opt; unless (mkdir(".testlink", 0777)) { rm_fr(".testlink"); mkdir(".testlink", 0777) || die "Cannot create .testlink dir: $!"; } chdir(".testlink"); open($cfile, ">Conftest.xs") || die "Cannot write to file Conftest.xs: $!"; print $cfile < #endif #include #include #include #ifdef __cplusplus } #endif EOT print $cfile $src; print $cfile <Conftest.pm") || die "Cannot write to file Conftest.pm: $!"; print $cfile <<'EOT'; package Conftest; $VERSION = 1.0; require DynaLoader; @ISA = ('DynaLoader'); bootstrap Conftest $VERSION; 1; EOT close($cfile); open($cfile, ">Makefile.PL") || die "Cannot write to file Makefile.PL: $!"; print $cfile <<'EOT'; use ExtUtils::MakeMaker; my %options; while($_ = shift @ARGV) { my ($k, $v) = split /=/, $_, 2; warn("$k = $v\n"); $options{$k} = $v; } WriteMakefile(NAME => "Conftest", VERSION_FROM => "Conftest.pm", %options); EOT close($cfile); open($cfile, ">test.pl") || die "Cannot write to file test.pl: $!"; print $cfile < 1; } END { ok(\$loaded) } use Conftest; \$loaded++; EOT close($cfile); my $quote = $is_Win32 ? '"' : "'"; xsystem("$^X Makefile.PL " . join(' ', map { "${quote}$_=$options{$_}${quote}" } keys %options)); xsystem("$Config{make} test ${quote}OTHERLDFLAGS=${opt}${quote}"); } # end try_link0 sub try_link { my $start_dir = cwd(); my $result = eval { try_link0(@_) }; warn $@ if $DEBUG && $@; chdir($start_dir); rm_fr(".testlink"); return $result; } sub have_library { my ($lib, $func, $header) = (@_, 'blank', 'blank'); printf("checking for %s() in -l%s... ", $func, $lib) if $func ne 'blank'; printf("looking for -l%s... ", $lib) if $func eq 'blank'; $header = $lib if $header eq 'blank'; my $result; # try to find a specific function in the library if ($func ne 'blank') { my $libs = $is_Win32 ? " $lib.lib " : "-l$lib"; if ($is_Win32) { $result = try_link(<<"SRC",undef ); #ifdef _CYGWIN #include #endif #include <${header}.h> int blank() { return 0; } int t() { ${func}(); return 0; } SRC unless ($result) { $result = try_link(<<"SRC", undef); #ifdef _CYGWIN #include #endif #include <${header}.h> int blank() { return 0; } int t() { void ((*p)()); p = (void ((*)()))${func}; return 0; } SRC } } else { $result = try_link(<<"SRC", undef); #include <${header}.h> int blank() { return 0; } int t() { ${func}(); return 0; } SRC } # no function was specified, so just try to load or link against the library } else { if($has_Win32) { my $driver_ok = Win32::LoadLibrary("${lib}.dll"); $result = 1 and Win32::FreeLibrary($driver_ok) if $driver_ok; } else { $result = try_link(<<"SRC", undef); #ifdef _CYGWIN #include #endif #include <${header}.h> int blank() { return 0; } SRC } } unless ($result) { print "no\n"; return 0; } if ($func ne "main") { $options{DEFINE} .= uc(" -Dhave_$func"); } print "yes\n"; return 1; } sub have_functions { my @funcs = (); print "detecting available functions... "; my @paths = DynaLoader::dl_findfile(qw(-lpcap)); my $libref = DynaLoader::dl_load_file($paths[0]); for my $func (@_) { my $symref = DynaLoader::dl_find_symbol($libref, $func); push @funcs, $func if defined $symref } print "ok\n"; return @funcs } sub cpp_defines { return join '', sort map { " -DHAVE_\U$_" } @_ } sub get_pcap_version { print "detecting libpcap version... "; use Config; my $cc = "$Config{cc} $options{CCFLAGS} $options{LDFLAGS} 'pcap_version.c' $options{LIBS} -o pcap_version.exe"; print "Running [$cc]\n"; system($cc) == 0 or return undef; my $res = `./pcap_version.exe`; if( $res ) { $res =~ s!\s+$!!; }; print "ok ($res)\n"; return $res } sub find_functions { # these functions are present since the very beginning so there's no need # to search for them my %old_func = map { $_ => 1 } qw( pcap_lookupdev pcap_lookupnet pcap_open_live pcap_open_offline pcap_close pcap_loop pcap_dispatch pcap_next pcap_stats pcap_compile pcap_freecode pcap_setfilter pcap_datalink pcap_dump_open pcap_dump_close pcap_dump pcap_file pcap_fileno pcap_snapshot pcap_is_swapped pcap_major_version pcap_minor_version pcap_perror pcap_strerror pcap_geterr ); my @funcs = (); # search for the functions list in the documentation open(PM, ') { next unless $line =~ /^=item +B<(pcap_\w+)\(.*\)>$/; push @funcs, $1 unless $old_func{$1}; } close(PM); return @funcs } Net-Pcap-0.21/t/0000755000175000017500000000000014362166275012666 5ustar corioncorionNet-Pcap-0.21/t/16-setnonblock.t0000644000175000017500000000544214362166261015620 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "pcap_setnonblock() and pcap_getnonblock() are not available" unless is_available('pcap_setnonblock'); plan tests => 23; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$r,$err) = ('','','',''); # Testing error messages SKIP: { skip "Test::Exception not available", 4 unless $has_test_exception; # setnonblock() errors throws_ok(sub { Net::Pcap::setnonblock() }, '/^Usage: Net::Pcap::setnonblock\(p\, nb, err\)/', "calling setnonblock() with no argument"); throws_ok(sub { Net::Pcap::setnonblock(0, 0, 0) }, '/^p is not of type pcap_tPtr/', "calling setnonblock() with incorrect argument type"); # getnonblock() errors throws_ok(sub { Net::Pcap::getnonblock() }, '/^Usage: Net::Pcap::getnonblock\(p\, err\)/', "calling getnonblock() with no argument"); throws_ok(sub { Net::Pcap::getnonblock(0, 0) }, '/^p is not of type pcap_tPtr/', "calling getnonblock() with incorrect argument type"); } SKIP: { skip "must be run as root", 13 unless is_allowed_to_use_pcap(); skip "no network device available", 13 unless find_network_device(); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); for my $state (0, 1) { # Testing setnonblock() eval { $r = Net::Pcap::setnonblock($pcap, $state, \$err) }; is( $@, '', "setnonblock() state=$state" ); is( $err, '', " - err must be null" ); is( $r, 0, " - should return zero" ); # Testing getnonblock() eval { $r = Net::Pcap::getnonblock($pcap, \$err) }; is( $@, '', "getnonblock()" ); is( $err, '', " - err must be null" ); is( $r, $state, " - state must be $state" ); } Net::Pcap::close($pcap); } # Open a sample dump $pcap = Net::Pcap::open_offline(File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)), \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; throws_ok(sub { Net::Pcap::setnonblock($pcap, 0, 0) }, '/^arg3 not a reference/', "calling setnonblock() with incorrect argument type for arg3"); throws_ok(sub { Net::Pcap::getnonblock($pcap, 0) }, '/^arg2 not a reference/', "calling getnonblock() with incorrect argument type for arg2"); } # Testing getnonblock() eval { $r = Net::Pcap::getnonblock($pcap, \$err) }; is( $@, '', "getnonblock()" ); is( $err, '', " - err must be null" ); is( $r, 0, " - state must be 0 for savefile" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/03-openlive.t0000644000175000017500000000357414362166261015120 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => 14; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$err) = ('','',''); # Testing error messages SKIP: { skip "Test::Exception not available", 4 unless $has_test_exception; # open_live() errors throws_ok(sub { Net::Pcap::open_live() }, '/^Usage: Net::Pcap::open_live\(device, snaplen, promisc, to_ms, err\)/', "calling open_live() with no argument"); throws_ok(sub { Net::Pcap::open_live(0, 0, 0, 0, 0) }, '/^arg5 not a reference/', "calling open_live() with no reference for arg5"); # close() errors throws_ok(sub { Net::Pcap::close() }, '/^Usage: Net::Pcap::close\(p\)/', "calling close() with no argument"); throws_ok(sub { Net::Pcap::close(0) }, '/^p is not of type pcap_tPtr/', "calling close() with incorrect argument type"); } # Find a device $dev = find_network_device(); # Testing open_live() eval { $pcap = Net::Pcap::open_live($dev, 1024, 1, 0, \$err) }; is( $@, '', "open_live()" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( defined $pcap, " - \$pcap is defined" ); isa_ok( $pcap, 'SCALAR', " - \$pcap" ); isa_ok( $pcap, 'pcap_tPtr', " - \$pcap" ); # Testing close() eval { Net::Pcap::close($pcap) }; is( $@, '', "close()" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; # Testing open_live() with fake device name my $fakedev = 'this is not a device'; eval { $pcap = Net::Pcap::open_live($fakedev, 1024, 1, 0, \$err) }; is( $@, '', "open_live()" ); cmp_ok( length($err), '>', 0, " - \$err must be set: $err" ); is( $pcap, undef, " - \$pcap isn't defined" ); $err = ''; Net-Pcap-0.21/t/17-lib_version.t0000644000175000017500000000077314362166261015615 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; plan tests => 2; # Testing lib_version() my $version = eval { Net::Pcap::lib_version() }; is( $@, '', "lib_version()" ); diag($version); if ($^O eq 'MSWin32' or $^O eq 'cygwin') { like( $version, '/^WinPcap version \d\.\d+/', " - checking version string ($version)" ); } else { like( $version, '/^libpcap version (?:\d+\.\d+(?:\.\d+|[^\d.\s]+)?|unknown \(pre 0\.8\))/', " - checking version string ($version)" ); } Net-Pcap-0.21/t/00-load.t0000644000175000017500000000024314362166261014201 0ustar corioncorion#!perl -T use strict; use Test::More tests => 1; use_ok( "Net::Pcap" ); diag( "Testing Net::Pcap $Net::Pcap::VERSION (", pcap_lib_version(), ") under Perl $]" ); Net-Pcap-0.21/t/podspell.t0000644000175000017500000000163614362166261014676 0ustar corioncorion#!perl use strict; use Test::More; plan skip_all => "Pod spelling: for maintainer only" unless -d "releases"; plan skip_all => "Test::Spelling required for checking Pod spell" unless eval "use Test::Spelling; 1"; if (`type spell 2>/dev/null`) { # default } elsif (`type aspell 2>/dev/null`) { set_spell_cmd('aspell -l --lang=en'); } else { plan skip_all => "spell(1) command or compatible required for checking Pod spell" } add_stopwords(); all_pod_files_spelling_ok(); __END__ SAPER Sébastien Aperghis Tramoni Aperghis-Tramoni CPAN README TODO AUTOLOADER API arrayref arrayrefs hashref hashrefs lookup hostname loopback netmask timestamp BPF CRC IP TCP UDP FDDI Firewire HDLC IEEE IrDA LocalTalk PPP LBL libpcap pcap WinPcap BOADLER JLMOREL KCARNUT PLISTER TIMPOTTER Bruhat Carnut Lanning Maischen Pradene savefile Savefile savefiles Savefiles snaplen endianness pcapinfo errbuf PerlMonks iptables Net-Pcap-0.21/t/50-anyevent-pcap.t0000644000175000017500000000335114362166261016044 0ustar corioncorion#!perl -Tw use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; BEGIN { *note = sub { print "# @_\n" } unless defined ¬e; } # first check that AnyEvent is available plan skip_all => "AnyEvent is not available" unless eval "use AnyEvent; 1"; # then check that AnyEvent::Pcap is available eval "use AnyEvent::Pcap"; my $error = $@; plan skip_all => "AnyEvent::Pcap is not available" if $error =~ /^Can't locate/; plan tests => 18; is $error, "", "use AnyEvent::Pcap"; my $dev = find_network_device(); SKIP: { skip "must be run as root", 17 unless is_allowed_to_use_pcap(); skip "no network device available", 17 unless $dev; my $ae_pcap; my $cv = AnyEvent->condvar; note "\$ae_pcap = AnyEvent::Pcap->new(device => $dev, ...)"; $ae_pcap = AnyEvent::Pcap->new( device => $dev, packet_handler => sub { process_packet(@_); $cv->send; }, ); note '$ae_pcap->run'; $ae_pcap->run; note '$cv->recv'; $cv->recv; } sub process_packet { note "> process_packet"; my ($header, $packet) = @_; ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header->{caplen} <= $header->{len}, " - coherency check: packet length (caplen <= len)" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); } Net-Pcap-0.21/t/leaktests/0000755000175000017500000000000014362166275014665 5ustar corioncorionNet-Pcap-0.21/t/leaktests/leaktest4.pl0000644000175000017500000000145514362166261017122 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks in dump() function # # $Id: leaktest4.pl,v 1.3 1999/05/05 02:11:59 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; die("Must run as root!\n"), if ($UID != 0); my($dev, $err, $pcap_t, $pcap_dumper_t); $dev = Net::Pcap::lookupdev(\$err); $pcap_t = Net::Pcap::open_live($dev, 1024, 1, 0, \$err); $pcap_dumper_t = Net::Pcap::dump_open($pcap_t, "/dev/null"); if (!defined($pcap_t)) { die("Net::Pcap::open_live returned error $err"); } my $count; sub process_pkt { my($user, $hdr, $pkt) = @_; $count++; Net::Pcap::dump($pcap_dumper_t, $hdr, $pkt); print("$count\n"), if (($count % 1000) == 0); } Net::Pcap::loop($pcap_t, 0, \&process_pkt, "1234"); Net::Pcap::dump_close($pcap_dumper_t); Net::Pcap::close($pcap_t); Net-Pcap-0.21/t/leaktests/leaktest2.pl0000644000175000017500000000053414362166261017115 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks in lookup functions # # $Id: leaktest2.pl,v 1.3 1999/05/05 02:11:58 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; my($dev, $net, $mask, $err, $result); while(1) { $dev = Net::Pcap::lookupdev(\$err); $result = Net::Pcap::lookupnet($dev, \$net, \$mask, \$err); } Net-Pcap-0.21/t/leaktests/leaktest6.pl0000644000175000017500000000130114362166261017112 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks in stats() function # # $Id: leaktest6.pl,v 1.3 1999/05/05 02:11:59 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; die("Must run as root!\n"), if ($UID != 0); my($dev, $err, $pcap_t); $dev = Net::Pcap::lookupdev(\$err); $pcap_t = Net::Pcap::open_live($dev, 1024, 1, 0, \$err); if (!defined($pcap_t)) { die("Net::Pcap::open_live returned error $err"); } my $count; sub process_pkt { my($user, $hdr, $pkt) = @_; my(%stats); $count++; Net::Pcap::stats($pcap_t, \%stats); print("$count\n"), if (($count % 1000) == 0); } Net::Pcap::loop($pcap_t, 0, \&process_pkt, "1234"); Net::Pcap::close($pcap_t); Net-Pcap-0.21/t/leaktests/leaktest1.pl0000644000175000017500000000134314362166261017113 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks by sitting in an infinite loop and flood # pinging from another window. Memory leaks become apparent quickly. # # $Id: leaktest1.pl,v 1.3 1999/05/05 02:11:58 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; die("Must run as root!\n"), if ($UID != 0); my($dev, $err, $pcap_t); $dev = Net::Pcap::lookupdev(\$err); $pcap_t = Net::Pcap::open_live($dev, 1024, 1, 0, \$err); if (!defined($pcap_t)) { die("Net::Pcap::open_live returned error $err"); } my $count; sub process_pkt { my($user, $hdr, $pkt) = @_; $count++; print("$count\n"), if (($count % 1000) == 0); } Net::Pcap::loop($pcap_t, 0, \&process_pkt, "1234"); Net::Pcap::close($pcap_t); Net-Pcap-0.21/t/leaktests/leaktest3.pl0000644000175000017500000000124014362166261017111 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks in dispatch() function. # # $Id: leaktest3.pl,v 1.3 1999/05/05 02:11:59 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; die("Must run as root!\n"), if ($UID != 0); my($dev, $err, $pcap_t); $dev = Net::Pcap::lookupdev(\$err); $pcap_t = Net::Pcap::open_live($dev, 1024, 1, 0, \$err); if (!defined($pcap_t)) { die("Net::Pcap::open_live returned error $err"); } my $count; sub process_pkt { my($user, $hdr, $pkt) = @_; $count++; print("$count\n"), if (($count % 1000) == 0); } while(1) { Net::Pcap::dispatch($pcap_t, 0, \&process_pkt, "1234"); } Net::Pcap::close($pcap_t); Net-Pcap-0.21/t/leaktests/leaktest5.pl0000644000175000017500000000126514362166261017122 0ustar corioncorion#!/usr/bin/perl -w # # Test for memory leaks in next() function. # # $Id: leaktest5.pl,v 1.3 1999/05/05 02:11:59 tpot Exp $ # use strict; use English; use ExtUtils::testlib; use Net::Pcap; die("Must run as root!\n"), if ($UID != 0); my($dev, $err, $pcap_t); $dev = Net::Pcap::lookupdev(\$err); $pcap_t = Net::Pcap::open_live($dev, 1024, 1, 0, \$err); if (!defined($pcap_t)) { die("Net::Pcap::open_live returned error $err"); } my $count; while(1) { my($pkt, %hdr); while (!($pkt = Net::Pcap::next($pcap_t, \%hdr))) { } $count++; print("$count\n"), if (($count % 1000) == 0); } Net::Pcap::loop($pcap_t, 0, \&process_pkt, "1234"); Net::Pcap::close($pcap_t); Net-Pcap-0.21/t/02-lookup.t0000644000175000017500000001771314362166261014607 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan tests => 45; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$net,$mask,$result,$err) = ('','','','',''); my @devs = (); my %devs = (); my %devinfo = (); my $ip_regexp = '/^[12]?\d+\.[12]?\d+\.[12]?\d+\.[12]?\d+$/'; # Testing error messages SKIP: { skip "Test::Exception not available", 17 unless $has_test_exception; # lookupdev() errors throws_ok(sub { Net::Pcap::lookupdev() }, '/^Usage: Net::Pcap::lookupdev\(err\)/', "calling lookupdev() with no argument"); throws_ok(sub { Net::Pcap::lookupdev(0) }, '/^arg1 not a hash ref/', "calling lookupdev() with incorrect argument type"); SKIP: { skip "pcap_findalldevs() is not available", 11 unless is_available('pcap_findalldevs'); # findalldevs() errors throws_ok(sub { Net::Pcap::findalldevs() }, '/^Usage: pcap_findalldevs\(devinfo, err\)/', "calling findalldevs() with no argument"); throws_ok(sub { Net::Pcap::findalldevs(0, 0, 0) }, '/^Usage: pcap_findalldevs\(devinfo, err\)/', "calling findalldevs() with too many arguments"); throws_ok(sub { Net::Pcap::findalldevs(0) }, '/^Usage: pcap_findalldevs\(devinfo, err\)/', "calling 1-arg findalldevs() with incorrect argument type"); throws_ok(sub { Net::Pcap::findalldevs(\%devinfo) }, '/^arg1 not a scalar ref/', "calling 1-arg findalldevs() with incorrect argument type"); throws_ok(sub { Net::Pcap::findalldevs(0, 0) }, '/^Usage: pcap_findalldevs\(devinfo, err\)/', "calling 2-args findalldevs() with incorrect argument type"); throws_ok(sub { Net::Pcap::findalldevs(\@devs, 0) }, '/^arg1 not a hash ref/', "calling 2-args findalldevs() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::findalldevs(\$err, 0) }, '/^arg2 not a hash ref/', "calling 2-args findalldevs() with incorrect argument type for arg2"); throws_ok(sub { Net::Pcap::findalldevs(\%devinfo, 0) }, '/^arg2 not a scalar ref/', "calling 2-args findalldevs() with incorrect argument type for arg2"); # findalldevs_xs() errors throws_ok(sub { Net::Pcap::findalldevs_xs() }, '/^Usage: Net::Pcap::findalldevs_xs\(devinfo, err\)/', "calling findalldevs_xs() with no argument"); throws_ok(sub { Net::Pcap::findalldevs_xs(0, 0) }, '/^arg1 not a hash ref/', "calling findalldevs_xs() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::findalldevs_xs(\%devinfo, 0) }, '/^arg2 not a scalar ref/', "calling findalldevs_xs() with incorrect argument type for arg2"); } # lookupnet() errors throws_ok(sub { Net::Pcap::lookupnet() }, '/^Usage: Net::Pcap::lookupnet\(device, net, mask, err\)/', "calling lookupnet() with no argument"); throws_ok(sub { Net::Pcap::lookupnet('', 0, 0, 0) }, '/^arg2 not a reference/', "calling lookupnet() with incorrect argument type for arg2"); throws_ok(sub { Net::Pcap::lookupnet('', \$net, 0, 0) }, '/^arg3 not a reference/', "calling lookupnet() with incorrect argument type for arg3"); throws_ok(sub { Net::Pcap::lookupnet('', \$net, \$mask, 0) }, '/^arg4 not a reference/', "calling lookupnet() with incorrect argument type for arg4"); } SKIP: { # Testing lookupdev() eval { $dev = Net::Pcap::lookupdev(\$err) }; is( $@, '', "lookupdev()" ); skip "error: $err. Skipping the rest of the tests", 27 if $err eq 'no suitable device found'; is( $err, '', " - \$err must be null: $err" ); $err = ''; isnt( $dev, '', " - \$dev isn't null: '$dev'" ); # Testing findalldevs() # findalldevs(\$err), legacy from Marco Carnut 0.05 eval { @devs = Net::Pcap::findalldevs(\$err) }; is( $@, '', "findalldevs() - 1-arg form, legacy from Marco Carnut 0.05" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( @devs >= 1, " - at least one device must be present in the list returned by findalldevs()" ); %devs = map { $_ => 1 } @devs; is( $devs{$dev}, 1, " - '$dev' must be present in the list returned by findalldevs()" ); # findalldevs(\$err, \%devinfo), legacy from Jean-Louis Morel 0.04.02 eval { @devs = Net::Pcap::findalldevs(\$err, \%devinfo) }; is( $@, '', "findalldevs() - 2-args form, legacy from Jean-Louis Morel 0.04.02" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( @devs >= 1, " - at least one device must be present in the list returned by findalldevs()" ); ok( keys %devinfo >= 1, " - at least one device must be present in the hash filled by findalldevs()" ); %devs = map { $_ => 1 } @devs; is( $devs{$dev}, 1, " - '$dev' must be present in the list returned by findalldevs()" ); SKIP: { is( $devinfo{'any'}, 'Pseudo-device that captures on all interfaces', " - checking pseudo-device description" ) and last if exists $devinfo{'any'}; skip "Pseudo-device not available", 1; } SKIP: { is( $devinfo{'lo' }, 'Loopback device', " - checking loopback device description" ) and last if exists $devinfo{'lo'}; is( $devinfo{'lo0'}, 'Loopback device', " - checking loopback device description" ) and last if exists $devinfo{'lo0'}; skip "Can't predict loopback device description", 1; } SKIP: { skip "pcap_findalldevs() is not available", 7 unless is_available('pcap_findalldevs'); # findalldevs(\%devinfo, \$err), new, correct syntax, consistent with libpcap(3) eval { @devs = Net::Pcap::findalldevs(\%devinfo, \$err) }; is( $@, '', "findalldevs() - 2-args form, new, correct syntax, consistent with libpcap(3)" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( @devs >= 1, " - at least one device must be present in the list returned by findalldevs()" ); ok( keys %devinfo >= 1, " - at least one device must be present in the hash filled by findalldevs()" ); %devs = map { $_ => 1 } @devs; is( $devs{$dev}, 1, " - '$dev' must be present in the list returned by findalldevs()" ); SKIP: { is( $devinfo{'any'}, 'Pseudo-device that captures on all interfaces', " - checking pseudo-device description" ) and last if exists $devinfo{'any'}; skip "Pseudo-device not available", 1; } SKIP: { is( $devinfo{'lo' }, 'Loopback device', " - checking loopback device description" ) and last if exists $devinfo{'lo'}; is( $devinfo{'lo0'}, 'Loopback device', " - checking loopback device description" ) and last if exists $devinfo{'lo0'}; skip "Can't predict loopback device description", 1; } } # Testing lookupnet() eval { $result = Net::Pcap::lookupnet($dev, \$net, \$mask, \$err) }; is( $@, '', "lookupnet()" ); SKIP: { skip "error: $err. Skipping lookupnet() tests", 6 if $result == -1; is( $err, '', " - \$err must be null: $err" ); $err = ''; is( $result, 0, " - \$result must be null: $result" ); isnt( $net, '', " - \$net isn't null: '$net' => ".dotquad($net) ); isnt( $mask, '', " - \$mask isn't null: '$mask' => ".dotquad($mask) ); like( dotquad($net), $ip_regexp, " - does \$net look like an IP address?" ); like( dotquad($mask), $ip_regexp, " - does \$mask look like an IP address?" ); } } sub dotquad { my($na, $nb, $nc, $nd); my($net) = @_ ; $na = $net >> 24 & 255 ; $nb = $net >> 16 & 255 ; $nc = $net >> 8 & 255 ; $nd = $net & 255 ; return "$na.$nb.$nc.$nd" } Net-Pcap-0.21/t/Utils.pm0000644000175000017500000000365514362166261014330 0ustar corioncorionuse strict; use Socket; $ENV{'LANG'} = $ENV{'LANGUAGE'} = $ENV{'LC_MESSAGES'} = 'C'; =pod =head1 NAME Utils - Utility functions for testing C =head1 FUNCTIONS =over 4 =item B Returns true if the given function name is available in the version of the pcap library the module is being built against. =cut my %available_func = (); FUNCS: { open(FUNCS, 'funcs.txt') or warn "can't read 'funcs.txt': $!\n" and next; while(my $line = ) { chomp $line; $available_func{$line} = 1; } close(FUNCS); } sub is_available { return $available_func{$_[0]} } =item B Returns true if the user running the test is allowed to use the packet capture library. On Unix systems, this function tries to open a raw socket. On Win32 systems (ActivePerl, Cygwin), it just checks whether the user has administrative privileges. =cut sub is_allowed_to_use_pcap { # Win32: ActivePerl, Cygwin if ($^O eq 'MSWin32' or $^O eq 'cygwin') { my $is_admin = 0; eval 'no warnings; use Win32; $is_admin = Win32::IsAdminUser()'; $is_admin = 1 if $@; # Win32::IsAdminUser() not available return $is_admin } # Unix systems else { if(socket(S, PF_INET, SOCK_RAW, getprotobyname('icmp'))) { close(S); return 1 } else { return 0 } } } =item B Returns the name of a device suitable for listening to network traffic. =cut my $err; my %devs = (); my @devs = Net::Pcap::findalldevs(\%devs, \$err); # filter out unusable devices @devs = grep { $_ ne "lo" and $_ ne "lo0" and $_ !~ /GenericDialupAdapter/ } @devs; # check if the user has specified a prefered device to use for tests if (open(PREF, "device.txt")) { my $dev = ; chomp $dev; unshift @devs, $dev; } sub find_network_device { return wantarray ? @devs : $devs[0] } =back =cut 1 Net-Pcap-0.21/t/23-srcstr.t0000644000175000017500000000546614362166261014623 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "pcap_createsrcstr() is not available" unless is_available('pcap_createsrcstr'); plan tests => 18; my $has_test_exception = eval "use Test::Exception; 1"; my($src,$r,$err) = ('',0,''); my($type,$host,$port,$name) = ('rpcap', 'fangorn', 12345, 'eth0'); # Testing error messages SKIP: { skip "Test::Exception not available", 9 unless $has_test_exception; # createsrcstr() errors throws_ok(sub { Net::Pcap::createsrcstr() }, '/^Usage: Net::Pcap::createsrcstr\(source, type, host, port, name, err\)/', "calling createsrcstr() with no argument"); throws_ok(sub { Net::Pcap::createsrcstr(0, 0, 0, 0, 0, 0) }, '/^arg1 not a reference/', "calling createsrcstr() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::createsrcstr(\$src, 0, 0, 0, 0, 0) }, '/^arg6 not a hash ref/', "calling createsrcstr() with incorrect argument type for arg6"); # parsesrcstr() errors throws_ok(sub { Net::Pcap::parsesrcstr() }, '/^Usage: Net::Pcap::parsesrcstr\(source, type, host, port, name, err\)/', "calling parsesrcstr() with no argument"); throws_ok(sub { Net::Pcap::parsesrcstr(0, 0, 0, 0, 0, 0) }, '/^arg2 not a reference/', "calling parsesrcstr() with incorrect argument type for arg2"); throws_ok(sub { Net::Pcap::parsesrcstr(0, \$type, 0, 0, 0, 0) }, '/^arg3 not a reference/', "calling parsesrcstr() with incorrect argument type for arg3"); throws_ok(sub { Net::Pcap::parsesrcstr(0, \$type, \$host, 0, 0, 0) }, '/^arg4 not a reference/', "calling parsesrcstr() with incorrect argument type for arg4"); throws_ok(sub { Net::Pcap::parsesrcstr(0, \$type, \$host, \$port, 0, 0) }, '/^arg5 not a reference/', "calling parsesrcstr() with incorrect argument type for arg5"); throws_ok(sub { Net::Pcap::parsesrcstr(0, \$type, \$host, \$port, \$name, 0) }, '/^arg6 not a reference/', "calling parsesrcstr() with incorrect argument type for arg6"); } $r = eval { createsrcstr(\$src, $type, $host, $port, $name, \$err) }; is( $@, '', "createsrcstr() " ); is( $r, 0, " - should return zero: $r" ); is( $src, "$type\://$host\:$port/$name", " - checking created source string" ); my($parsed_type,$parsed_host,$parsed_port,$parsed_name) = ('','','',''); $r = eval { parsesrcstr($src, \$parsed_type, \$parsed_host, \$parsed_port, \$parsed_name, \$err) }; is( $@, '', "parsesrcstr() " ); is( $r, 0, " - should return zero: $r" ); is( $parsed_type, $type, " - checking parsed type" ); is( $parsed_host, $host, " - checking parsed host" ); is( $parsed_port, $port, " - checking parsed port" ); is( $parsed_name, $name, " - checking parsed name" ); Net-Pcap-0.21/t/11-snapshot.t0000644000175000017500000000243414362166261015127 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my @sizes = (128, 512, 1024, 2048, 4096, 8192, int(10000*rand), int(10000*rand), int(10000*rand), int(10000*rand)); # snapshot sizes plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => @sizes * 2 + 2; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$snapshot,$err) = ('','','',''); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # snapshot() errors throws_ok(sub { Net::Pcap::snapshot() }, '/^Usage: Net::Pcap::snapshot\(p\)/', "calling snapshot() with no argument"); throws_ok(sub { Net::Pcap::snapshot(0) }, '/^p is not of type pcap_tPtr/', "calling snapshot() with incorrect argument type"); } # Find a device $dev = find_network_device(); for my $size (@sizes) { # Open the device $pcap = Net::Pcap::open_live($dev, $size, 1, 100, \$err); # Testing snapshot() $snapshot = 0; eval { $snapshot = Net::Pcap::snapshot($pcap) }; is( $@, '', "snapshot()" ); is( $snapshot, $size, " - snapshot has the expected size" ); Net::Pcap::close($pcap); } Net-Pcap-0.21/t/podcover.t0000644000175000017500000000044714362166261014674 0ustar corioncorion#!perl -T use strict; use Test::More; plan skip_all => "Currently not working for Net::Pcap"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" unless eval "use Test::Pod::Coverage 1.08; 1"; all_pod_coverage_ok({ also_private => [ '^constant$', '^.*_xs$' ] }); Net-Pcap-0.21/t/10-fileno.t0000644000175000017500000000732014362166261014542 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "no network device available" unless find_network_device(); plan tests => 21; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$filehandle,$fileno,$err) = ('','','','',''); # Testing error messages SKIP: { skip "Test::Exception not available", 6 unless $has_test_exception; # file() errors throws_ok(sub { Net::Pcap::file() }, '/^Usage: Net::Pcap::file\(p\)/', "calling file() with no argument"); throws_ok(sub { Net::Pcap::file(0) }, '/^p is not of type pcap_tPtr/', "calling file() with incorrect argument type"); # fileno() errors throws_ok(sub { Net::Pcap::fileno() }, '/^Usage: Net::Pcap::fileno\(p\)/', "calling fileno() with no argument"); throws_ok(sub { Net::Pcap::fileno(0) }, '/^p is not of type pcap_tPtr/', "calling fileno() with incorrect argument type"); skip "pcap_get_selectable_fd() is not available", 2 unless is_available('pcap_get_selectable_fd'); # get_selectable_fd() errors throws_ok(sub { Net::Pcap::get_selectable_fd() }, '/^Usage: Net::Pcap::get_selectable_fd\(p\)/', "calling get_selectable_fd() with no argument"); throws_ok(sub { Net::Pcap::get_selectable_fd(0) }, '/^p is not of type pcap_tPtr/', "calling get_selectable_fd() with incorrect argument type"); } SKIP: { skip "must be run as root", 7 unless is_allowed_to_use_pcap(); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing file() $filehandle = 0; eval { $filehandle = Net::Pcap::file($pcap) }; is( $@, '', "file() on a live connection" ); is( $filehandle, undef, " - returned filehandle should be undef" ); # Testing fileno() $fileno = undef; eval { $fileno = Net::Pcap::fileno($pcap) }; is( $@, '', "fileno() on a live connection" ); like( $fileno, '/^\d+$/', " - fileno must be an integer: $fileno" ); skip "pcap_get_selectable_fd() is not available", 2 unless is_available('pcap_get_selectable_fd'); # Testing get_selectable_fd() $fileno = undef; eval { $fileno = Net::Pcap::get_selectable_fd($pcap) }; is( $@, '', "get_selectable_fd() on a live connection" ); like( $fileno, '/^\d+$/', " - fileno must be an integer: $fileno" ); Net::Pcap::close($pcap); } # Open a sample dump $pcap = Net::Pcap::open_offline(File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)), \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing file() TODO: { todo_skip "file() on a dump file currently causes a segmentation fault", 3; eval { $filehandle = Net::Pcap::file($pcap) }; is( $@, '', "file() on a dump file" ); ok( defined $filehandle, " - returned filehandle must be defined" ); isa_ok( $filehandle, 'GLOB', " - \$filehandle" ); } # Testing fileno() eval { $fileno = Net::Pcap::fileno($pcap) }; is( $@, '', "fileno() on a dump file" ); # fileno() is documented to return -1 when called on save file, but seems # to always return an actual file number. TODO: { local $TODO = " => result should be -1"; like( $fileno, '/^(?:\d+|-1)$/', " - fileno must be an integer: $fileno" ); } # Testing get_selectable_fd() SKIP: { skip "pcap_get_selectable_fd() is not available", 2 unless is_available('pcap_get_selectable_fd'); $fileno = undef; eval { $fileno = Net::Pcap::get_selectable_fd($pcap) }; is( $@, '', "get_selectable_fd() on a dump file" ); like( $fileno, '/^\d+$/', " - fileno must be an integer: $fileno" ); } Net::Pcap::close($pcap); Net-Pcap-0.21/t/05-dump.t0000644000175000017500000001155414362166261014243 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 10; # number of packets to process plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 22 + 20; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$dumper,$dump_file,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 10 unless $has_test_exception; # dump_open() errors throws_ok(sub { Net::Pcap::dump_open() }, '/^Usage: Net::Pcap::dump_open\(p, fname\)/', "calling dump_open() with no argument"); throws_ok(sub { Net::Pcap::dump_open(0, 0) }, '/^p is not of type pcap_tPtr/', "calling dump_open() with incorrect argument type"); # dump() errors throws_ok(sub { Net::Pcap::dump() }, '/^Usage: Net::Pcap::dump\(p, pkt_header, sp\)/', "calling dump() with no argument"); throws_ok(sub { Net::Pcap::dump(0, 0, 0) }, '/^p is not of type pcap_dumper_tPtr/', "calling dump() with incorrect argument type for arg1"); # dump_close() errors throws_ok(sub { Net::Pcap::dump_close() }, '/^Usage: Net::Pcap::dump_close\(p\)/', "calling dump_close() with no argument"); throws_ok(sub { Net::Pcap::dump_close(0) }, '/^p is not of type pcap_dumper_tPtr/', "calling dump_close() with incorrect argument type"); # dump_file() errors throws_ok(sub { Net::Pcap::dump_file() }, '/^Usage: Net::Pcap::dump_file\(p\)/', "calling dump_file() with no argument"); throws_ok(sub { Net::Pcap::dump_file(0) }, '/^p is not of type pcap_dumper_tPtr/', "calling dump_file() with incorrect argument type"); SKIP: { skip "pcap_dump_flush() is not available", 2 unless is_available('pcap_dump_flush'); # dump_flush() errors throws_ok(sub { Net::Pcap::dump_flush() }, '/^Usage: Net::Pcap::dump_flush\(p\)/', "calling dump_flush() with no argument"); throws_ok(sub { Net::Pcap::dump_flush(0) }, '/^p is not of type pcap_dumper_tPtr/', "calling dump_flush() with incorrect argument type"); } } # Testing dump_open() eval q{ use File::Temp qw(:mktemp); $dump_file = mktemp('pcap-XXXXXX') }; $dump_file ||= "pcap-$$.dmp"; my $user_text = "Net::Pcap test suite"; my $count = 0; my $size = 0; eval { $dumper = Net::Pcap::dump_open($pcap, $dump_file) }; is( $@, '', "dump_open()" ); ok( defined $dumper, " - dumper is defined" ); TODO: { todo_skip "Hmm.. when executed, dump_file() corrupts something somewhere, making this script dumps core at the end", 3; my $filehandle; eval { $filehandle = Net::Pcap::dump_file($dumper) }; is( $@, '', "dump_file()" ); ok( defined $filehandle, "returned filehandle is defined" ); isa_ok( $filehandle, 'GLOB', "\$filehandle" ); } # Testing error messages SKIP: { skip "Test::Exception not available", 1 unless $has_test_exception; # dump() errors throws_ok(sub { Net::Pcap::dump($dumper, 0, 0) }, '/^arg2 not a hash ref/', "calling dump() with incorrect argument type for arg2"); } sub process_packet { my($user_data, $header, $packet) = @_; pass( "process_packet() callback" ); is( $user_data, $user_text, " - user data is the expected text" ); ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header->{caplen} <= $header->{len}, " - caplen <= len" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); eval { Net::Pcap::dump($dumper, $header, $packet) }; is( $@, '', "dump()"); SKIP: { skip "pcap_dump_flush() is not available", 2 unless is_available('pcap_dump_flush'); my $r; eval { $r = Net::Pcap::dump_flush($dumper) }; is( $@, '', "dump_flush()"); is( $r, 0, " - result: $r" ); } $size += $header->{caplen}; $count++; } Net::Pcap::loop($pcap, $total, \&process_packet, $user_text); is( $count, $total, "all packets processed" ); eval { Net::Pcap::dump_close($dumper) }; is( $@, '', "dump_close()" ); ok( -f $dump_file, "dump file created" ); ok( -s $dump_file >= $size, "dump file size" ); unlink($dump_file); Net::Pcap::close($pcap); Net-Pcap-0.21/t/14-datalink.t0000644000175000017500000001316414362166261015064 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; use Net::Pcap; use lib 't'; use Utils; my(%name2val,%val2name,%val2descr); plan skip_all => "extended datalink related functions are not available" unless is_available('pcap_datalink_name_to_val'); %name2val = ( undef => -1, LTalk => DLT_LTALK, raw => DLT_RAW, PPP_serial => DLT_PPP_SERIAL, SLIP => DLT_SLIP, ieee802_11 => DLT_IEEE802_11, ); %val2name = ( 0 => 'NULL', DLT_LTALK() => 'LTALK', DLT_RAW() => 'RAW', DLT_PPP_SERIAL() => 'PPP_SERIAL', DLT_SLIP() => 'SLIP', DLT_IEEE802_11() => 'IEEE802_11', ); %val2descr = ( 0 => 'BSD loopback', DLT_NULL() => 'BSD loopback', DLT_LTALK() => 'Localtalk', DLT_RAW() => 'Raw IP', DLT_PPP_SERIAL() => 'PPP over serial', DLT_SLIP() => 'SLIP', DLT_IEEE802_11() => '802.11', ); plan tests => keys(%name2val) * 2 + keys(%val2name) * 2 + keys(%val2descr) * 2 + 23; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$datalink,$r,$err) = ('','','','',''); # Testing error messages SKIP: { skip "Test::Exception not available", 7 unless $has_test_exception; # datalink() errors throws_ok(sub { Net::Pcap::datalink() }, '/^Usage: Net::Pcap::datalink\(p\)/', "calling datalink() with no argument"); throws_ok(sub { Net::Pcap::datalink(0) }, '/^p is not of type pcap_tPtr/', "calling datalink() with incorrect argument type"); # set_datalink() errors throws_ok(sub { Net::Pcap::set_datalink() }, '/^Usage: Net::Pcap::set_datalink\(p, linktype\)/', "calling set_datalink() with no argument"); throws_ok(sub { Net::Pcap::set_datalink(0, 0) }, '/^p is not of type pcap_tPtr/', "calling set_datalink() with incorrect argument type"); # datalink_name_to_val() errors throws_ok(sub { Net::Pcap::datalink_name_to_val() }, '/^Usage: Net::Pcap::datalink_name_to_val\(name\)/', "calling datalink_name_to_val() with no argument"); # datalink_val_to_name() errors throws_ok(sub { Net::Pcap::datalink_val_to_name() }, '/^Usage: Net::Pcap::datalink_val_to_name\(linktype\)/', "calling datalink_val_to_name() with no argument"); # datalink_val_to_descr() errors throws_ok(sub { Net::Pcap::datalink_val_to_description() }, '/^Usage: Net::Pcap::datalink_val_to_description\(linktype\)/', "calling datalink_val_to_description() with no argument"); } SKIP: { skip "must be run as root", 5 unless is_allowed_to_use_pcap(); skip "no network device available", 5 unless find_network_device(); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing datalink() $datalink = ''; eval { $datalink = Net::Pcap::datalink($pcap) }; is( $@, '', "datalink() on a live connection" ); like( $datalink , '/^\d+$/', " - datalink is an integer" ); # Testing set_datalink() eval { $r = Net::Pcap::set_datalink($pcap, DLT_LTALK) }; # Apple LocalTalk is( $@, '', "set_datalink() on a live connection" ); is( $r , -1, " - returned -1 (expected failure)" ); Net::Pcap::close($pcap); } # Open a sample save file $pcap = Net::Pcap::open_offline(File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)), \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing datalink() $datalink = ''; eval { $datalink = Net::Pcap::datalink($pcap) }; is( $@, '', "datalink() on a save file" ); like( $datalink , '/^\d+$/', " - datalink is an integer" ); is( $datalink , DLT_EN10MB, " - datalink is DLT_EN10MB (Ethernet)" ); # Testing set_datalink() eval { $r = Net::Pcap::set_datalink($pcap, DLT_LTALK) }; # Apple LocalTalk is( $@, '', "set_datalink() on a save file" ); is( $r , -1, " - returned -1 (expected failure)" ); Net::Pcap::close($pcap); # Open a dead pcap descriptor $pcap = Net::Pcap::open_dead(DLT_IP_OVER_FC, 1024); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); # Testing datalink() $datalink = ''; eval { $datalink = Net::Pcap::datalink($pcap) }; is( $@, '', "datalink() on a dead descriptor" ); is( $datalink , DLT_IP_OVER_FC, " - datalink is an integer" ); # Testing set_datalink() # the migration of the century: from IP-over-Fibre Channel to Apple LocalTalk! eval { $r = Net::Pcap::set_datalink($pcap, DLT_LTALK) }; is( $@, '', "set_datalink() on a dead descriptor" ); is( $r , -1, " - returned -1 (expected failure)" ); # The following tests don't work, but maybe they're just incorrect. #isnt( $r , -1, " - should not returned -1" ); #$datalink = Net::Pcap::datalink($pcap); #is( $datalink, DLT_LTALK, " - new link type was correctly stored" ); # Testing datalink_name_to_val() for my $name (keys %name2val) { $datalink = ''; eval { $datalink = Net::Pcap::datalink_name_to_val($name) }; is( $@, '', "datalink_name_to_val($name)" ); is( $datalink, $name2val{$name}, " - checking expected value" ); } # Testing datalink_val_to_name() for my $val (keys %val2name) { my $name = ''; eval { $name = Net::Pcap::datalink_val_to_name($val) }; is( $@, '', "datalink_val_to_name($val)" ); is( $name, $val2name{$val}, " - checking expected value" ); } # Testing datalink_val_to_description() for my $val (keys %val2descr) { my $descr = ''; eval { $descr = Net::Pcap::datalink_val_to_description($val) }; is( $@, '', "datalink_val_to_description($val)" ); is( $descr, $val2descr{$val}, " - checking expected value" ); } Net-Pcap-0.21/t/portfs.t0000644000175000017500000000044514362166261014366 0ustar corioncorion#!perl -T use strict; use Test::More; plan skip_all => "Only for the module maintainer" unless $ENV{AUTHOR_TESTS}; plan skip_all => "Test::Portability::Files required for testing filenames portability" unless eval "use Test::Portability::Files; 1"; # run the selected tests run_tests(); Net-Pcap-0.21/t/50-poe-component-pcap.t0000644000175000017500000000444114362166261016777 0ustar corioncorion#!perl -Tw use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; BEGIN { *note = sub { print "# @_\n" } unless defined ¬e; } # first check that POE is available plan skip_all => "POE is not available" unless eval "use POE; 1"; # then check that POE::Component::Pcap is available eval "use POE::Component::Pcap"; my $error = $@; plan skip_all => "POE::Component::Pcap is not available" if $error =~ /^Can't locate/; plan tests => 18; is( $error, '', "use POE::Component::Pcap" ); my $dev = find_network_device(); SKIP: { skip "must be run as root", 17 unless is_allowed_to_use_pcap(); skip "no network device available", 17 unless $dev; note "[POE] create"; POE::Session->create( inline_states => { _start => \&start, _stop => \&stop, got_packet => \&got_packet, }, ); note "[POE] run"; POE::Kernel->run; } sub start { note "[POE:start] spawning new Pcap session ", $_[&SESSION]->ID, " on device $dev"; POE::Component::Pcap->spawn( Alias => 'pcap', Device => $dev, Dispatch => 'got_packet', Session => $_[&SESSION], ); $_[&KERNEL]->post(pcap => open_live => $dev); $_[&KERNEL]->post(pcap => 'run'); } sub stop { note "[POE:stop]"; $_[&KERNEL]->post(pcap => 'shutdown'); } sub got_packet { note "[POE:got_packet]"; my $packets = $_[&ARG0]; # process the first packet only process_packet(@{ $packets->[0] }); # send a message to stop the capture $_[&KERNEL]->post(pcap => 'shutdown'); } sub process_packet { note "[POE:process_packet]"; my ($header, $packet) = @_; ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header->{caplen} <= $header->{len}, " - coherency check: packet length (caplen <= len)" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); } Net-Pcap-0.21/t/09-error.t0000644000175000017500000000240514362166261014426 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "no network device available" unless find_network_device(); plan tests => 10; my($dev,$net,$mask,$pcap,$filter,$res,$err) = ('','',0,'','','',''); # Find a device and open it $dev = find_network_device(); $res = Net::Pcap::lookupnet($dev, \$net, \$mask, \$err); $pcap = Net::Pcap::open_dead(DLT_EN10MB, 1024); # Testing compile() with an invalid filter eval { $res = Net::Pcap::compile($pcap, \$filter, "this is not a filter", 0, $mask) }; is( $@, '', "compile() with an invalid filter string" ); is( $res, -1, " - result must not be null: $res" ); eval { $err = Net::Pcap::geterr($pcap) }; is( $@, '', "geterr()" ); like( $err, '/(^|: )(?:parse|syntax) error$/', " - \$err must not be null: $err" ); # Testing compile() with a valid filter eval { $res = Net::Pcap::compile($pcap, \$filter, "tcp", 0, $mask) }; is( $@, '', "compile() with a valid filter string" ); is( $res, 0, " - result must be null: $res" ); eval { $err = Net::Pcap::geterr($pcap) }; is( $@, '', "geterr()" ); is( $err, '', " - \$err must be null" ); # Testing strerror() eval { $err = Net::Pcap::strerror(1) }; is( $@, '', "strerror()" ); isnt( $err, '', " - \$err must not be null" ); Net-Pcap-0.21/t/50-net-pcap-easy.t0000644000175000017500000000333214362166261015737 0ustar corioncorion#!perl -Tw use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; BEGIN { *note = sub { print "# @_\n" } unless defined ¬e; } # check that Net::Pcap::Easy is available eval "use Net::Pcap::Easy"; my $error = $@; plan skip_all => "Net::Pcap::Easy is not available" if $error =~ /^Can't locate/; plan tests => 18; is $error, "", "use Net::Pcap::Easy"; my $dev = find_network_device(); my $done = 0; SKIP: { skip "must be run as root", 17 unless is_allowed_to_use_pcap(); skip "no network device available", 17 unless $dev; my $npe = Net::Pcap::Easy->new( dev => $dev, packets_per_loop => 1, bytes_to_capture => 1024, tcp_callback => \&process_tcp_packet, ); $npe->loop until $done; } sub process_tcp_packet { note "> process_tcp_packet"; my ($npe, $ether, $ip, $tcp, $header ) = @_; my $xmit = localtime $header->{tv_sec}; note "$xmit TCP: $ip->{src_ip}:$tcp->{src_port}" . " -> $ip->{dest_ip}:$tcp->{dest_port}"; ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header->{caplen} <= $header->{len}, " - coherency check: packet length (caplen <= len)" ); my $packet = $ether->{_frame}; ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); $done = 1; } Net-Pcap-0.21/t/21-next_ex.t0000644000175000017500000000473014362166261014744 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 3; # number of packets to process plan skip_all => "pcap_next_ex() is not available" unless is_available('pcap_next_ex'); plan skip_all => "slowness and random failures... testing pcap_next_ex() is a PITA"; plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 17 + 4; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$net,$mask,$filter,$data,$r,$err) = ('','','','','','',''); my %header = (); # Find a device and open it $dev = find_network_device(); Net::Pcap::lookupnet($dev, \$net, \$mask, \$err); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 4 unless $has_test_exception; # next_ex() errors throws_ok(sub { Net::Pcap::next_ex() }, '/^Usage: Net::Pcap::next_ex\(p, pkt_header, pkt_data\)/', "calling next_ex() with no argument"); throws_ok(sub { Net::Pcap::next_ex(0, 0, 0) }, '/^p is not of type pcap_tPtr/', "calling next_ex() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::next_ex($pcap, 0, 0) }, '/^arg2 not a hash ref/', "calling next_ex() with incorrect argument type for arg2"); throws_ok(sub { Net::Pcap::next_ex($pcap, \%header, 0) }, '/^arg3 not a scalar ref/', "calling next_ex() with incorrect argument type for arg3"); } # Compile and set a filter Net::Pcap::compile($pcap, \$filter, "ip", 0, $mask); Net::Pcap::setfilter($pcap, $filter); # Test next_ex() my $count = 0; for (1..$total) { my($packet, %header); eval { $r = Net::Pcap::next_ex($pcap, \%header, \$packet) }; is( $@, '', "next_ex()" ); is( $r, 1, " - should return 1 ($r)" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header{$field}, " - field '$field' is present" ); ok( defined $header{$field}, " - field '$field' is defined" ); like( $header{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header{caplen} <= $header{len}, " - coherency check: packet length (caplen <= len)" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header{caplen}, " - packet has the advertised size" ); $count++; } is( $count, $total, "all packets processed" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/12-next.t0000644000175000017500000000417014362166261014246 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 3; # number of packets to process plan skip_all => "pcap_next() behaves too strangely for being tested on random machines"; plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 16 + 4; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$net,$mask,$filter,$data,$r,$err) = ('','','','','','',''); my %header = (); # Find a device and open it $dev = find_network_device(); Net::Pcap::lookupnet($dev, \$net, \$mask, \$err); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 3 unless $has_test_exception; # next() errors throws_ok(sub { Net::Pcap::next() }, '/^Usage: Net::Pcap::next\(p, pkt_header\)/', "calling next() with no argument"); throws_ok(sub { Net::Pcap::next(0, 0) }, '/^p is not of type pcap_tPtr/', "calling next() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::next($pcap, 0) }, '/^arg2 not a hash ref/', "calling next() with incorrect argument type for arg2"); } # Compile and set a filter Net::Pcap::compile($pcap, \$filter, "ip", 0, $mask); Net::Pcap::setfilter($pcap, $filter); # Test next() my $count = 0; for (1..$total) { my($packet, %header); eval { $packet = Net::Pcap::next($pcap, \%header) }; is( $@, '', "next()" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header{$field}, " - field '$field' is present" ); ok( defined $header{$field}, " - field '$field' is defined" ); like( $header{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header{caplen} <= $header{len}, " - coherency check: packet length (caplen <= len)" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header{caplen}, " - packet has the advertised size" ); $count++; } is( $count, $total, "all packets processed" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/01-api.t0000644000175000017500000000246514362166261014044 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; plan tests => 3; # ---[ copied from Pcap.pm ]---------------------------------------------------- # functions names my @func_short_names = qw( lookupdev findalldevs lookupnet open_live open_dead open_offline loop breakloop close dispatch next next_ex compile compile_nopcap setfilter freecode offline_filter setnonblock getnonblock dump_open dump dump_file dump_flush dump_close datalink set_datalink datalink_name_to_val datalink_val_to_name datalink_val_to_description snapshot is_swapped major_version minor_version stats file fileno get_selectable_fd geterr strerror perror lib_version createsrcstr parsesrcstr open setbuff setuserbuffer setmode setmintocopy getevent sendpacket sendqueue_alloc sendqueue_queue sendqueue_transmit ); my @func_long_names = map { "pcap_$_" } @func_short_names; # ------------------------------------------------------------------------------ # check that the following functions are available (old API) can_ok( "Net::Pcap", @func_short_names ); # check that the following functions are available (new API) can_ok( "Net::Pcap", @func_long_names ); # check that the following functions are available (new API) can_ok( __PACKAGE__, @func_long_names ); Net-Pcap-0.21/t/19-breakloop.t0000644000175000017500000000330014362166261015247 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "pcap_breakloop() is not available" unless is_available('pcap_breakloop'); plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => 5; my $has_test_exception = eval "use Test::Exception; 1"; my $total = 10; # number of packets to process my($dev,$pcap,$dumper,$dump_file,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # breakloop() errors throws_ok(sub { Net::Pcap::breakloop() }, '/^Usage: Net::Pcap::breakloop\(p\)/', "calling breakloop() with no argument"); throws_ok(sub { Net::Pcap::breakloop(0) }, '/^p is not of type pcap_tPtr/', "calling breakloop() with incorrect argument type"); } # Testing stats() my $user_text = "Net::Pcap test suite"; my $count = 0; sub process_packet { my($user_data, $header, $packet) = @_; my %stats = (); if(++$count == $total/2) { eval { Net::Pcap::breakloop($pcap) }; is( $@, '', "breakloop()" ); } } my $r = Net::Pcap::loop($pcap, $total, \&process_packet, $user_text); ok( ($r == -2 or $r == $count), "checking loop() return value" ); is( $count, $total/2, "half the packets processed" ); # Note: I'm not sure why $count is always $total/2 even when $r == -2 # Maybe I just don't understand what the docmentation says. # Or maybe I shouldn't write tests at 02:10 %-) Net::Pcap::close($pcap); Net-Pcap-0.21/t/pod.t0000644000175000017500000000024114362166261013625 0ustar corioncorion#!perl -T use strict; use Test::More; plan skip_all => "Test::Pod 1.14 required for testing POD" unless eval "use Test::Pod 1.14; 1"; all_pod_files_ok(); Net-Pcap-0.21/t/13-dispatch.t0000644000175000017500000000367014362166261015074 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 1; # number of packets to process plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 11 + 5; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$dumper,$dump_file,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # dispatch() errors throws_ok(sub { Net::Pcap::dispatch() }, '/^Usage: Net::Pcap::dispatch\(p, cnt, callback, user\)/', "calling dispatch() with no argument"); throws_ok(sub { Net::Pcap::dispatch(0, 0, 0, 0) }, '/^p is not of type pcap_tPtr/', "calling dispatch() with incorrect argument type"); } my $user_text = "Net::Pcap test suite"; my $count = 0; sub process_packet { my($user_data, $header, $packet) = @_; my %stats = (); eval { Net::Pcap::stats($pcap, \%stats) }; is( $@, '', "stats()" ); is( keys %stats, 3, " - %stats has 3 elements" ); for my $field (qw(ps_recv ps_drop ps_ifdrop)) { ok( exists $stats{$field}, " - field '$field' is present" ); ok( defined $stats{$field}, " - field '$field' is defined" ); like( $stats{$field}, '/^\d+$/', " - field '$field' is a number" ); } $count++; } my $retval = 0; eval { $retval = Net::Pcap::dispatch($pcap, $total, \&process_packet, $user_text) }; is( $@, '', "dispatch()" ); SKIP: { skip "not enought packets or other unknown problem", 11 * ($total - $count) + 2 if $count < $total; is( $count, $total, "checking the number of processed packets" ); is( $retval, $count, "checking return value" ); } Net::Pcap::close($pcap); Net-Pcap-0.21/t/24-offline_filter.t0000644000175000017500000000235314362166261016263 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $has_test_exception = eval "use Test::Exception; 1"; plan tests => 7; my ($r, $err, $icmpfilter, $tcpfilter); my $path = File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)); my $pcap = pcap_open_offline($path, \$err); ok $pcap, 'open testfile'; $r = eval { pcap_compile($pcap, \$icmpfilter, 'icmp', 1, 0xffffffff) }; is $r, 0, 'compile icmp filter'; $r = eval { pcap_compile($pcap, \$tcpfilter, 'tcp', 1, 0xffffffff) }; is $r, 0, 'compile tcp filter'; SKIP: { skip "Test::Exception not available", 1 unless $has_test_exception; # check offline_filter() errors throws_ok(sub { pcap_offline_filter($tcpfilter, undef, undef) }, '/^arg2 not a hash ref/', "calling offline_filter() with no argument"); } my (%header, $packet); my ($n, $icmp, $tcp) = (0, 0, 0); while (pcap_next_ex($pcap, \%header, \$packet) == 1) { $n++; $icmp++ if pcap_offline_filter($icmpfilter, \%header, $packet); $tcp++ if pcap_offline_filter($tcpfilter, \%header, $packet); } pcap_close($pcap); is $n, 20, 'read all packets'; is $icmp, 20, 'found all icmp packets'; is $tcp, 0, 'test for tcp packets in an icmp-only testfile'; Net-Pcap-0.21/t/08-filter.t0000644000175000017500000001132514362166261014562 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan tests => 29; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$net,$mask,$pcap,$filter,$res,$err) = ('','',0,'','','',''); # Find a device $dev = find_network_device(); $res = Net::Pcap::lookupnet($dev, \$net, \$mask, \$err); SKIP: { skip "pcap_compile_nopcap() is not available", 7 unless is_available('pcap_compile_nopcap'); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # compile_nopcap() throws_ok(sub { Net::Pcap::compile_nopcap() }, '/^Usage: Net::Pcap::compile_nopcap\(snaplen, linktype, fp, str, optimize, mask\)/', "calling compile_nopcap() with no argument"); throws_ok(sub { Net::Pcap::compile_nopcap(0, 0, 0, 0, 0, 0) }, '/^arg3 not a reference/', "calling compile_nopcap() with incorrect argument type for arg2"); } # Testing compile_nopcap() eval { $res = Net::Pcap::compile_nopcap(1024, DLT_EN10MB, \$filter, "tcp", 0, $mask) }; is( $@, '', "compile_nopcap()" ); is( $res, 0, " - result must be null: $res" ); ok( defined $filter, " - \$filter is defined" ); isa_ok( $filter, 'SCALAR', " - \$filter" ); isa_ok( $filter, 'pcap_bpf_program_tPtr', " - \$filter" ); } SKIP: { skip "must be run as root", 22 unless is_allowed_to_use_pcap(); skip "no network device available", 22 unless find_network_device(); # Open the device $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 10 unless $has_test_exception; # compile() errors throws_ok(sub { Net::Pcap::compile() }, '/^Usage: Net::Pcap::compile\(p, fp, str, optimize, mask\)/', "calling compile() with no argument"); throws_ok(sub { Net::Pcap::compile(0, 0, 0, 0, 0) }, '/^p is not of type pcap_tPtr/', "calling compile() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::compile($pcap, 0, 0, 0, 0) }, '/^arg2 not a reference/', "calling compile() with incorrect argument type for arg2"); # geterr() errors throws_ok(sub { Net::Pcap::geterr() }, '/^Usage: Net::Pcap::geterr\(p\)/', "calling compile() with no argument"); throws_ok(sub { Net::Pcap::geterr(0) }, '/^p is not of type pcap_tPtr/', "calling geterr() with incorrect argument type for arg1"); # setfilter() errors throws_ok(sub { Net::Pcap::setfilter() }, '/^Usage: Net::Pcap::setfilter\(p, fp\)/', "calling setfilter() with no argument"); throws_ok(sub { Net::Pcap::setfilter(0, 0) }, '/^p is not of type pcap_tPtr/', "calling setfilter() with incorrect argument type for arg1"); throws_ok(sub { Net::Pcap::setfilter($pcap, 0) }, '/^fp is not of type pcap_bpf_program_tPtr/', "calling setfilter() with incorrect argument type for arg2"); # freecode() errors throws_ok(sub { Net::Pcap::freecode() }, '/^Usage: Net::Pcap::freecode\(fp\)/', "calling freecode() with no argument"); throws_ok(sub { Net::Pcap::freecode(0) }, '/^fp is not of type pcap_bpf_program_tPtr/', "calling freecode() with incorrect argument type for arg1"); } # Testing compile() eval { $res = Net::Pcap::compile($pcap, \$filter, "tcp", 0, $mask) }; is( $@, '', "compile()" ); is( $res, 0, " - result must be null: $res" ); ok( defined $filter, " - \$filter is defined" ); isa_ok( $filter, 'SCALAR', " - \$filter" ); isa_ok( $filter, 'pcap_bpf_program_tPtr', " - \$filter" ); # Testing geterr() eval { $err = Net::Pcap::geterr($pcap) }; is( $@, '', "geterr()" ); if($res == 0) { is( $err, '', " - \$err should be null" ) } else { isnt( $err, '', " - \$err should not be null" ) } # Testing setfilter() eval { $res = Net::Pcap::setfilter($pcap, $filter) }; is( $@, '', "setfilter()" ); is( $res, 0, " - result should be null: $res" ); # Testing freecode() eval { Net::Pcap::freecode($filter) }; is( $@, '', "freecode()" ); # Testing geterr() eval { $err = Net::Pcap::geterr($pcap) }; is( $@, '', "geterr()" ); if($res == 0) { is( $err, '', " - \$err should be null" ) } else { isnt( $err, '', " - \$err should not be null" ) } Net::Pcap::close($pcap); } Net-Pcap-0.21/t/07-stats.t0000644000175000017500000000401114362166261014424 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 10; # number of packets to process plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 13 + 4; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$dumper,$dump_file,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 3 unless $has_test_exception; # stats() errors throws_ok(sub { Net::Pcap::stats() }, '/^Usage: Net::Pcap::stats\(p, ps\)/', "calling stats() with no argument"); throws_ok(sub { Net::Pcap::stats(0, 0) }, '/^p is not of type pcap_tPtr/', "calling stats() with incorrect argument type"); throws_ok(sub { Net::Pcap::stats($pcap, 0) }, '/^arg2 not a hash ref/', "calling stats() with no reference for arg2"); } # Testing stats() my $user_text = "Net::Pcap test suite"; my $count = 0; sub process_packet { my($user_data, $header, $packet) = @_; my %stats = (); my $r = undef; eval { $r = Net::Pcap::stats($pcap, \%stats) }; is( $@, '', "stats()" ); is( $r, 0, " - should return zero" ); is( keys %stats, 3, " - %stats has 3 elements" ); for my $field (qw(ps_recv ps_drop ps_ifdrop)) { ok( exists $stats{$field}, " - field '$field' is present" ); ok( defined $stats{$field}, " - field '$field' is defined" ); like( $stats{$field}, '/^\d+$/', " - field '$field' is a number" ); } $count++; TODO: { local $TODO = "BUG: ps_recv not correctly set"; is( $stats{ps_recv}, $count, " - coherency check: number of processed packets" ); } } Net::Pcap::loop($pcap, $total, \&process_packet, $user_text); is( $count, $total, "all packets processed" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/20-constants.t0000644000175000017500000000231114362166261015276 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; my $macrosall = 'macros.all'; open(MACROS, $macrosall) or plan skip_all => "can't read '$macrosall': $!"; my @names = map {chomp;$_} ; close(MACROS); plan tests => @names * 2 + 2; my $callpack = 'Net::Pcap'; my $testpack = 'pcap'; eval "use $callpack"; eval "${callpack}::This()"; like( $@, "/^This is not a valid $testpack macro/", "trying a non-existing macro"); eval "${callpack}::NOSUCHNAME()"; like( $@, "/^NOSUCHNAME is not a valid $testpack macro/", "trying a non-existing macro"); # Testing all macros if(@names) { for my $name (@names) { SKIP: { $name =~ /^(\w+)$/ or skip "invalid name '$name'", 2; $name = $1; my $v = eval "${callpack}::$name()"; if(defined $v and $v =~ /^\d+$/) { is( $@, '', "calling the constant $name as a function" ); like( $v, '/^\d+$/', "checking that $name is a number ($v)" ); } else { like( $@, "/^Your vendor has not defined $testpack macro $name/", "calling the constant via its name" ); skip "irrelevant test in this case", 1 } } } } Net-Pcap-0.21/t/README0000644000175000017500000000107114362166261013540 0ustar corioncorionMost of these tests need to bypass the TCP/IP stack in order to directly open the network interface, which generally requires administrative privileges or appropriate access rights. The tests are skipped if the user account running these does not have the required rights. Note that some of these tests require a working network interface with actual traffic on it. For example the loop test waits for 10 packets to be received on the network before exiting. If there is no traffic on the interface, this test will block. The memory leak tests do not complete. Net-Pcap-0.21/t/samples/0000755000175000017500000000000014362166275014332 5ustar corioncorionNet-Pcap-0.21/t/samples/ping-ietf-20pk-le.dmp0000644000175000017500000000433014362166261020061 0ustar corioncorionÔòĄ`m¸Cý `bĐ(Ě$ n ĂĘET@@ĽÄ „—KI¤YGm¸Cé   !"#$%&'()*+,-./012345m¸C•›`b n ĂʐĐ(Ě$ET[ď6“Ő„—K Q¤YGm¸Cé   !"#$%&'()*+,-./012345s¸Cz``bĐ(Ě$ n ĂĘET@@ĽĂ „—KĎWYGs¸Ci`  !"#$%&'()*+,-./012345s¸Cîň`b n ĂʐĐ(Ě$ET[đ6“Ô„—K ×WYGs¸Ci`  !"#$%&'()*+,-./012345x¸CÜ`bĐ(Ě$ n ĂĘET@@ĽÂ „—Kb˛YGx¸CÍ  !"#$%&'()*+,-./012345x¸C ˜`b n ĂʐĐ(Ě$ET[ń6“Ó„—K j˛YGx¸CÍ  !"#$%&'()*+,-./012345}¸C{„ `bĐ(Ě$ n ĂĘET@@ĽÁ „—Kź1YG}¸Ch„   !"#$%&'()*+,-./012345}¸Cű3 `b n ĂʐĐ(Ě$ET[ň6“Ň„—K Ä1YG}¸Ch„   !"#$%&'()*+,-./012345‚¸CÓ=`bĐ(Ě$ n ĂĘET@@ĽŔ „—K[wYG‚¸CŔ=  !"#$%&'()*+,-./012345ƒ¸CL‡`b n ĂʐĐ(Ě$ET[ó6“Ń„—K cwYG‚¸CŔ=  !"#$%&'()*+,-./012345ˆ¸C¤Š`bĐ(Ě$ n ĂĘET@@Ľż „—K’)YGˆ¸CŠ  !"#$%&'()*+,-./012345ˆ¸C1 `b n ĂʐĐ(Ě$ET[ô6“Đ„—K š)YGˆ¸CŠ  !"#$%&'()*+,-./012345¸CŚ`bĐ(Ě$ n ĂĘET@@Ľž „—K…˘YG¸C“  !"#$%&'()*+,-./012345¸CH—`b n ĂʐĐ(Ě$ET[ő6“Ď„—K ˘YG¸C“  !"#$%&'()*+,-./012345’¸Ciž `bĐ(Ě$ n ĂĘET@@Ľ˝ „—KşYG’¸CVž   !"#$%&'()*+,-./012345’¸C˝! `b n ĂʐĐ(Ě$ET[ö6“΄—K ÂYG’¸CVž   !"#$%&'()*+,-./012345—¸C´( `bĐ(Ě$ n ĂĘET@@Ľź „—KdˆYG —¸CŁ(   !"#$%&'()*+,-./012345˜¸CĂi`b n ĂʐĐ(Ě$ET[÷6“Í„—K lˆYG —¸CŁ(   !"#$%&'()*+,-./012345¸C y`bĐ(Ě$ n ĂĘET @@Ľť „—K7YG ¸C y  !"#$%&'()*+,-./012345¸Cš`b n ĂʐĐ(Ě$ET[ř6“Ě„—K  7YG ¸C y  !"#$%&'()*+,-./012345Net-Pcap-0.21/t/samples/ping-ietf-20pk-be.dmp0000644000175000017500000000433014362166261020047 0ustar corioncorionĄ˛ĂÔ`CšŞ Đ}`bĐ(Ě$PüG…šETý”@č0 „—K"WKCšŞ Ϟ  !"#$%&'()*+,-./012345CšŞ _0`bPüG…šĐ(Ě$ET[ů6“Ě„—K *WKCšŞ Ϟ  !"#$%&'()*+,-./012345CšŤ Ń,`bĐ(Ě$PüG…šETý•@č/ „—K!JKCšŤ ĐŠ  !"#$%&'()*+,-./012345CšŤ ^ý`bPüG…šĐ(Ě$ET[ú6“Ë„—K )JKCšŤ ĐŠ  !"#$%&'()*+,-./012345CšŹ Ó`bĐ(Ě$PüG…šETý–@č. „—K lKCšŹ х  !"#$%&'()*+,-./012345CšŹ Zą`bPüG…šĐ(Ě$ET[ű6“Ę„—K (lKCšŹ х  !"#$%&'()*+,-./012345Cš­ Óř`bĐ(Ě$PüG…šETý—@č- „—KzKCš­ Óu  !"#$%&'()*+,-./012345Cš­ ZÉ`bPüG…šĐ(Ě$ET[ü6“É„—K &zKCš­ Óu  !"#$%&'()*+,-./012345CšŽ ÔŮ`bĐ(Ě$PüG…šETý˜@č, „—K–KCšŽ ÔW  !"#$%&'()*+,-./012345CšŽ W%`bPüG…šĐ(Ě$ET[ý6“Č„—K %–KCšŽ ÔW  !"#$%&'()*+,-./012345CšŻ ŐĹ`bĐ(Ě$PüG…šETý™@č+ „—KŞKCšŻ ŐA  !"#$%&'()*+,-./012345CšŻ KŽ`bPüG…šĐ(Ě$ET[ţ6“Ç„—K $ŞKCšŻ ŐA  !"#$%&'()*+,-./012345Cš° Öŕ`bĐ(Ě$PüG…šETýš@č* „—KŒKCš° Ö]  !"#$%&'()*+,-./012345Cš° _B`bPüG…šĐ(Ě$ET[˙6“Ć„—K #ŒKCš° Ö]  !"#$%&'()*+,-./012345Cšą ×ă`bĐ(Ě$PüG…šETý›@č) „—KŠKCšą ×]  !"#$%&'()*+,-./012345Cšą SA`bPüG…šĐ(Ě$ET\6“Ĺ„—K "ŠKCšą ×]  !"#$%&'()*+,-./012345Cš˛ ŘÇ`bĐ(Ě$PüG…šETýœ@č( „—KĄKCš˛ ŘD  !"#$%&'()*+,-./012345Cš˛ ^k`bPüG…šĐ(Ě$ET\6“Ä„—K !ĄKCš˛ ŘD  !"#$%&'()*+,-./012345Cšł Ú@`bĐ(Ě$PüG…šETý@č' „—K(K Cšł Ůť  !"#$%&'()*+,-./012345Cšł f;`bPüG…šĐ(Ě$ET\6“Ă„—K  (K Cšł Ůť  !"#$%&'()*+,-./012345Net-Pcap-0.21/t/06-offline.t0000644000175000017500000001163614362166261014722 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 10; # number of packets to process plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 19 * 2 + 23; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$dumper,$dump_file,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # open_offline() errors throws_ok(sub { Net::Pcap::open_offline() }, '/^Usage: Net::Pcap::open_offline\(fname, err\)/', "calling open_offline() with no argument"); throws_ok(sub { Net::Pcap::open_offline(0, 0) }, '/^arg2 not a reference/', "calling open_offline() with incorrect argument type for arg2"); } # Testing open_offline() eval q{ use File::Temp qw(:mktemp); $dump_file = mktemp('pcap-XXXXXX'); }; $dump_file ||= "pcap-$$.dmp"; # calling open_offline() with a non-existent file name eval { Net::Pcap::open_offline($dump_file, \$err) }; is( $@, '', "open_offline() with non existent dump file" ); isnt( $err, '', " - \$err is not null: $err" ); $err = ''; # creating a dump file $dumper = Net::Pcap::dump_open($pcap, $dump_file); my $user_text = "Net::Pcap test suite"; my $count = 0; my @data1 = (); sub store_packet { my($user_data, $header, $packet) = @_; pass( "process_packet() callback" ); is( $user_data, $user_text, " - user data is the expected text" ); ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number: $header->{$field}" ); } ok( $header->{caplen} <= $header->{len}, " - caplen <= len" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); Net::Pcap::dump($dumper, $header, $packet); push @data1, [$header, $packet]; $count++; } Net::Pcap::loop($pcap, $total, \&store_packet, $user_text); is( $count, $total, "all packets processed" ); Net::Pcap::dump_close($dumper); # now opening this dump file eval { $pcap = Net::Pcap::open_offline($dump_file, \$err) }; is( $@, '', "open_offline() with existent dump file" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( defined $pcap, " - \$pcap is defined" ); isa_ok( $pcap, 'SCALAR', " - \$pcap" ); isa_ok( $pcap, 'pcap_tPtr', " - \$pcap" ); my($major, $minor, $swapped); eval { $major = Net::Pcap::major_version($pcap) }; is( $@, '', "major_version()" ); like( $major, '/^\d+$/', " - major is a number: $major" ); eval { $minor = Net::Pcap::minor_version($pcap) }; is( $@, '', "minor_version()" ); like( $minor, '/^\d+$/', " - minor is a number: $minor" ); eval { $swapped = Net::Pcap::is_swapped($pcap) }; is( $@, '', "is_swapped()" ); like( $swapped, '/^[01]$/', " - swapped is 0 or 1: $swapped" ); $count = 0; my @data2 = (); sub read_packet { my($user_data, $header, $packet) = @_; pass( "process_packet() callback" ); is( $user_data, $user_text, " - user data is the expected text" ); ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number: $header->{$field}" ); } ok( $header->{caplen} <= $header->{len}, " - caplen <= len" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); push @data2, [$header, $packet]; $count++; } Net::Pcap::loop($pcap, $total, \&read_packet, $user_text); is( $count, $total, "all packets processed" ); TODO: { local $TODO = "caplen is sometimes wrong, dunno why"; is_deeply( \@data1, \@data2, "checking data" ); } Net::Pcap::close($pcap); unlink($dump_file); # Testing open_offline() using known samples $dump_file = File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)); eval { $pcap = Net::Pcap::open_offline($dump_file, \$err) }; is( $@, '', "open_offline() with existent dump file" ); is( $err, '', " - \$err must be null: $err" ); $err = ''; ok( defined $pcap, " - \$pcap is defined" ); isa_ok( $pcap, 'SCALAR', " - \$pcap" ); isa_ok( $pcap, 'pcap_tPtr', " - \$pcap" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/22-open.t0000644000175000017500000000656514362166261014244 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap qw(:openflag :mode); use lib 't'; use Utils; plan skip_all => "pcap_open() is not available" unless is_available('pcap_open'); plan tests => 24; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$r,$err) = ('','','',''); # Find a device and open it $dev = find_network_device(); # Testing error messages SKIP: { skip "Test::Exception not available", 11 unless $has_test_exception; # pcap_open() errors throws_ok(sub { Net::Pcap::open() }, '/^Usage: Net::Pcap::open\(source, snaplen, flags, read_timeout, auth, err\)/', "calling pcap_open() with no argument"); throws_ok(sub { Net::Pcap::open(0, 0, 0, 0, 0, 0) }, '/^arg6 not a reference/', "calling pcap_open() with incorrect argument type for arg6"); throws_ok(sub { Net::Pcap::open(0, 0, 0, 0, 0, \$err) }, '/^arg5 not a hash ref/', "calling pcap_open() with incorrect argument type for arg5"); # setbuff() errors throws_ok(sub { Net::Pcap::setbuff() }, '/^Usage: Net::Pcap::setbuff\(p, dim\)/', "calling setbuff() with no argument"); throws_ok(sub { Net::Pcap::setbuff(0, 0) }, '/^arg1 not a reference/', "calling setbuff() with no argument"); # setuserbuffer() errors throws_ok(sub { Net::Pcap::userbuffer() }, '/^Usage: Net::Pcap::setbuff\(p, size\)/', "calling userbuffer() with no argument"); throws_ok(sub { Net::Pcap::userbuffer(0, 0) }, '/^arg1 not a reference/', "calling userbuffer() with no argument"); # setmode() errors throws_ok(sub { Net::Pcap::setmode() }, '/^Usage: Net::Pcap::setmode\(p, mode\)/', "calling setmode() with no argument"); throws_ok(sub { Net::Pcap::setmode(0, 0) }, '/^arg1 not a reference/', "calling setmode() with no argument"); # setmintocopy() errors throws_ok(sub { Net::Pcap::setmintocopy() }, '/^Usage: Net::Pcap::setmintocopy\(p, size\)/', "calling setmintocopy() with no argument"); throws_ok(sub { Net::Pcap::setmintocopy(0, 0) }, '/^arg1 not a reference/', "calling setmintocopy() with no argument"); } SKIP: { skip "must be run as root", 13 unless is_allowed_to_use_pcap(); skip "no network device available", 13 unless find_network_device(); # Testing pcap_open() $pcap = eval { Net::Pcap::open($dev, 1000, OPENFLAG_PROMISCUOUS, 1000, undef, \$err) }; is( $@, '', "pcap_open()" ); is( $err, '', " - \$err must be null: $err" ); ok( defined $pcap, " - returned a defined value" ); isa_ok( $pcap, 'SCALAR', " - \$pcap" ); isa_ok( $pcap, 'pcap_tPtr', " - \$pcap" ); # Testing setbuff() $r = eval { Net::Pcap::setbuff($pcap, 8*1024) }; is( $@, '', "setbuff()" ); is( $r, 0, " - return 0 for true" ); # Testing setuserbuffer() $r = eval { Net::Pcap::setuserbuffer($pcap, 8*1024) }; is( $@, '', "setuserbuffer()" ); is( $r, 0, " - return 0 for true" ); # Testing setmode() $r = eval { Net::Pcap::setmode($pcap, MODE_CAPT) }; is( $@, '', "setmode()" ); is( $r, 0, " - return 0 for true" ); # Testing setmintocopy() $r = eval { Net::Pcap::setmintocopy($pcap, 8*1024) }; is( $@, '', "setmintocopy()" ); is( $r, 0, " - return 0 for true" ); Net::Pcap::close($pcap); } Net-Pcap-0.21/t/15-is_swapped.t0000644000175000017500000000223114362166261015425 0ustar corioncorion#!perl -T use strict; use File::Spec; use Test::More; use Net::Pcap; plan tests => 5; my($pcap,$err) = ('',''); # from perlport/"Numbers endianness and Width" my $is_big_endian = unpack("h*", pack("s", 1)) =~ /01/; my $is_little_endian = unpack("h*", pack("s", 1)) =~ /^1/; is( $is_big_endian, !$is_little_endian, "checking flags consistency" ); my $type = $is_big_endian ? "big" : "little"; diag("This platform has been detected as a $type endian architecture"); # make these values numbers because is_swapped() return 0 or 1, not true or false $is_big_endian += 0; $is_little_endian += 0; # testing with a big endian dump $pcap = Net::Pcap::open_offline(File::Spec->catfile(qw(t samples ping-ietf-20pk-be.dmp)), \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); is( Net::Pcap::is_swapped($pcap) , $is_little_endian, "testing with a big endian dump" ); Net::Pcap::close($pcap); # testing with a little endian dump $pcap = Net::Pcap::open_offline(File::Spec->catfile(qw(t samples ping-ietf-20pk-le.dmp)), \$err); isa_ok( $pcap, 'pcap_tPtr', "\$pcap" ); is( Net::Pcap::is_swapped($pcap) , $is_big_endian, "testing with a little endian dump" ); Net::Pcap::close($pcap); Net-Pcap-0.21/t/18-open_dead.t0000644000175000017500000000153514362166261015216 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; plan skip_all => "pcap_open_dead() is not available" unless is_available('pcap_open_dead'); plan tests => 5; my $has_test_exception = eval "use Test::Exception; 1"; my($pcap,$datalink) = ('',0); # datalink == DLT_NULL => no link-layer encapsulation # Testing error messages SKIP: { skip "Test::Exception not available", 1 unless $has_test_exception; # open_dead() errors throws_ok(sub { Net::Pcap::open_dead() }, '/^Usage: Net::Pcap::open_dead\(linktype, snaplen\)/', "calling open_dead() with no argument"); } # Testing open_dead() eval { $pcap = Net::Pcap::open_dead($datalink, 1024) }; is( $@, '', "open_dead()" ); ok( defined $pcap, " - \$pcap is defined" ); isa_ok( $pcap, 'SCALAR', " - \$pcap" ); isa_ok( $pcap, 'pcap_tPtr', " - \$pcap" ); Net-Pcap-0.21/t/distchk.t0000644000175000017500000000030414362166261014474 0ustar corioncorion#!perl use strict; use Test::More; plan skip_all => "Test::Distribution required for checking distribution" unless eval "use Test::Distribution not => [qw(versions prereq podcover use)]; 1"; Net-Pcap-0.21/t/04-loop.t0000644000175000017500000000405114362166261014240 0ustar corioncorion#!perl -T use strict; use Test::More; use Net::Pcap; use lib 't'; use Utils; my $total = 10; # number of packets to process plan skip_all => "must be run as root" unless is_allowed_to_use_pcap(); plan skip_all => "no network device available" unless find_network_device(); plan tests => $total * 19 + 5; my $has_test_exception = eval "use Test::Exception; 1"; my($dev,$pcap,$err) = ('','',''); # Find a device and open it $dev = find_network_device(); $pcap = Net::Pcap::open_live($dev, 1024, 1, 100, \$err); # Testing error messages SKIP: { skip "Test::Exception not available", 2 unless $has_test_exception; # loop() errors throws_ok(sub { Net::Pcap::loop() }, '/^Usage: Net::Pcap::loop\(p, cnt, callback, user\)/', "calling loop() with no argument"); throws_ok(sub { Net::Pcap::loop(0, 0, 0, 0) }, '/^p is not of type pcap_tPtr/', "calling loop() with incorrect argument type"); } # Testing loop() my $user_text = "Net::Pcap test suite"; my $count = 0; sub process_packet { my($user_data, $header, $packet) = @_; pass( "process_packet() callback" ); is( $user_data, $user_text, " - user data is the expected text" ); ok( defined $header, " - header is defined" ); isa_ok( $header, 'HASH', " - header" ); for my $field (qw(len caplen tv_sec tv_usec)) { ok( exists $header->{$field}, " - field '$field' is present" ); ok( defined $header->{$field}, " - field '$field' is defined" ); like( $header->{$field}, '/^\d+$/', " - field '$field' is a number" ); } ok( $header->{caplen} <= $header->{len}, " - coherency check: packet length (caplen <= len)" ); ok( defined $packet, " - packet is defined" ); is( length $packet, $header->{caplen}, " - packet has the advertised size" ); $count++; } my $retval = eval { Net::Pcap::loop($pcap, $total, \&process_packet, $user_text) }; is( $@, '', "loop()" ); is( $count, $total, "all packets processed" ); is( $retval, 0, "checking return value" ); Net::Pcap::close($pcap); Net-Pcap-0.21/.gitignore0000644000175000017500000000033014362166261014402 0ustar corioncorionMakefile Makefile.old *.tar.gz *.bak pm_to_blib blib/ Net-Pcap-* Net-Pcap-*/ .releaserc cover_db MYMETA.* *.bs *.def Pcap.c *.a *.o const-c.inc const-xs.inc funcs.txt macros.all pcap_version.exe Net-Pcap-0.21/META.yml0000644000175000017500000000134614362166275013700 0ustar corioncorion--- abstract: 'Interface to the pcap(3) LBL packet capture library' author: - 'Sebastien Aperghis-Tramoni ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Pcap no_index: directory: - t - inc requires: Carp: '0' Socket: '0' Sys::Hostname: '0' Test::More: '0.45' XSLoader: '0' perl: '5.006001' resources: repository: https://github.com/maddingue/Net-Pcap version: '0.21' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-Pcap-0.21/Pcap.pm0000644000175000017500000011176114362166261013646 0ustar corioncorion# # Pcap.pm # # An interface to the LBL pcap(3) library. This module simply # bootstraps the extensions defined in Pcap.xs # # Copyright (C) 2005-2009 Sebastien Aperghis-Tramoni. All rights reserved. # Copyright (C) 2003 Marco Carnut. All rights reserved. # Copyright (C) 1999, 2000 Tim Potter. All rights reserved. # Copyright (C) 1998 Bo Adler. All rights reserved. # Copyright (C) 1997 Peter Lister. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # package Net::Pcap; use strict; use warnings; use Exporter 'import'; use Carp; # functions names my @func_short_names = qw( lookupdev findalldevs lookupnet open_live open_dead open_offline loop breakloop close dispatch next next_ex compile compile_nopcap setfilter freecode offline_filter setnonblock getnonblock dump_open dump dump_file dump_flush dump_close datalink set_datalink datalink_name_to_val datalink_val_to_name datalink_val_to_description snapshot is_swapped major_version minor_version stats file fileno get_selectable_fd geterr strerror perror lib_version createsrcstr parsesrcstr open setbuff setuserbuffer setmode setmintocopy getevent sendpacket sendqueue_alloc sendqueue_queue sendqueue_transmit ); my @func_long_names = map { "pcap_$_" } @func_short_names; # functions aliases { no strict "refs"; for my $func (@func_short_names) { *{ __PACKAGE__ . "::pcap_$func" } = \&{ __PACKAGE__ . "::" . $func } } } { our $VERSION = '0.21'; our %EXPORT_TAGS = ( 'bpf' => [qw( BPF_ALIGNMENT BPF_MAJOR_VERSION BPF_MAXBUFSIZE BPF_MAXINSNS BPF_MEMWORDS BPF_MINBUFSIZE BPF_MINOR_VERSION BPF_RELEASE )], 'datalink' => [qw( DLT_AIRONET_HEADER DLT_APPLE_IP_OVER_IEEE1394 DLT_ARCNET DLT_ARCNET_LINUX DLT_ATM_CLIP DLT_ATM_RFC1483 DLT_AURORA DLT_AX25 DLT_CHAOS DLT_CHDLC DLT_CISCO_IOS DLT_C_HDLC DLT_DOCSIS DLT_ECONET DLT_EN10MB DLT_EN3MB DLT_ENC DLT_FDDI DLT_FRELAY DLT_HHDLC DLT_IBM_SN DLT_IBM_SP DLT_IEEE802 DLT_IEEE802_11 DLT_IEEE802_11_RADIO DLT_IEEE802_11_RADIO_AVS DLT_IPFILTER DLT_IP_OVER_FC DLT_JUNIPER_ATM1 DLT_JUNIPER_ATM2 DLT_JUNIPER_ES DLT_JUNIPER_GGSN DLT_JUNIPER_MFR DLT_JUNIPER_MLFR DLT_JUNIPER_MLPPP DLT_JUNIPER_MONITOR DLT_JUNIPER_SERVICES DLT_LINUX_IRDA DLT_LINUX_SLL DLT_LOOP DLT_LTALK DLT_NULL DLT_OLD_PFLOG DLT_PCI_EXP DLT_PFLOG DLT_PFSYNC DLT_PPP DLT_PPP_BSDOS DLT_PPP_ETHER DLT_PPP_SERIAL DLT_PRISM_HEADER DLT_PRONET DLT_RAW DLT_RIO DLT_SLIP DLT_SLIP_BSDOS DLT_SUNATM DLT_SYMANTEC_FIREWALL DLT_TZSP DLT_USER0 DLT_USER1 DLT_USER2 DLT_USER3 DLT_USER4 DLT_USER5 DLT_USER6 DLT_USER7 DLT_USER8 DLT_USER9 DLT_USER10 DLT_USER11 DLT_USER12 DLT_USER13 DLT_USER14 DLT_USER15 )], mode => [qw( MODE_CAPT MODE_MON MODE_STAT )], openflag => [qw( OPENFLAG_PROMISCUOUS OPENFLAG_DATATX_UDP OPENFLAG_NOCAPTURE_RPCAP )], pcap => [qw( PCAP_ERRBUF_SIZE PCAP_IF_LOOPBACK PCAP_VERSION_MAJOR PCAP_VERSION_MINOR )], rpcap => [qw( RMTAUTH_NULL RMTAUTH_PWD )], sample => [qw( PCAP_SAMP_NOSAMP PCAP_SAMP_1_EVERY_N PCAP_SAMP_FIRST_AFTER_N_MS )], source => [qw( PCAP_SRC_FILE PCAP_SRC_IFLOCAL PCAP_SRC_IFREMOTE )], functions => [qw( lookupdev findalldevs lookupnet open_live open_dead open_offline dump_open dump_close dump_file dump_flush compile compile_nopcap setfilter freecode offline_filter setnonblock getnonblock dispatch next_ex loop breakloop datalink set_datalink datalink_name_to_val datalink_val_to_name datalink_val_to_description snapshot get_selectable_fd stats is_swapped major_version minor_version geterr strerror perror lib_version createsrcstr parsesrcstr setbuff setuserbuffer setmode setmintocopy getevent sendpacket sendqueue_alloc sendqueue_queue sendqueue_transmit )], ); our @EXPORT = ( @{$EXPORT_TAGS{pcap}}, @{$EXPORT_TAGS{datalink}}, @func_long_names, "UNSAFE_SIGNALS", ); our @EXPORT_OK = ( @{$EXPORT_TAGS{functions}}, @{$EXPORT_TAGS{mode}}, @{$EXPORT_TAGS{openflag}}, @{$EXPORT_TAGS{bpf}}, ); eval { require XSLoader; XSLoader::load('Net::Pcap', $VERSION); 1 } or do { require DynaLoader; push our @ISA, 'DynaLoader'; bootstrap Net::Pcap $VERSION; }; } sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. my $constname; ($constname = our $AUTOLOAD) =~ s/.*:://; return if $constname eq "DESTROY"; croak "Net::Pcap::constant() not defined" if $constname eq 'constant'; my ($error, $val) = constant($constname); if ($error) { croak $error; } { no strict "refs"; # Fixed between 5.005_53 and 5.005_61 #XXX if ($] >= 5.00561) { #XXX *$AUTOLOAD = sub () { $val }; #XXX } else { *$AUTOLOAD = sub { $val }; #XXX } } goto &$AUTOLOAD; } # pseudo-bloc to enable immediate (unsafe) signals delivery sub UNSAFE_SIGNALS (&) { $_[0]->(); } # Perl wrapper for DWIM sub findalldevs { croak "Usage: pcap_findalldevs(devinfo, err)" unless @_ and @_ <= 2 and ref $_[0]; # findalldevs(\$err), legacy from Marco Carnut 0.05 my %devinfo = (); ( ref $_[0] eq 'SCALAR' and return findalldevs_xs(\%devinfo, $_[0]) ) or croak "arg1 not a scalar ref" if @_ == 1; # findalldevs(\$err, \%devinfo), legacy from Jean-Louis Morel 0.04.02 ref $_[0] eq 'SCALAR' and ( ( ref $_[1] eq 'HASH' and return findalldevs_xs($_[1], $_[0]) ) or croak "arg2 not a hash ref" ); # findalldevs(\%devinfo, \$err), new, correct syntax, consistent with libpcap(3) ref $_[0] eq 'HASH' and ( ( ref $_[1] eq 'SCALAR' and return findalldevs_xs($_[0], $_[1]) ) or croak "arg2 not a scalar ref" ); # if here, the function was called with incorrect arguments ref $_[0] ne 'HASH' and croak "arg1 not a hash ref"; } 1; __END__ =encoding UTF-8 =head1 NAME Net::Pcap - Interface to the pcap(3) LBL packet capture library =head1 VERSION Version 0.21 =head1 SYNOPSIS use Net::Pcap; my $err = ''; my $dev = pcap_lookupdev(\$err); # find a device # open the device for live listening my $pcap = pcap_open_live($dev, 1024, 1, 0, \$err); # loop over next 10 packets pcap_loop($pcap, 10, \&process_packet, "just for the demo"); # close the device pcap_close($pcap); sub process_packet { my ($user_data, $header, $packet) = @_; # do something ... } =head1 DESCRIPTION C is a Perl binding to the LBL pcap(3) library and its Win32 counterpart, the WinPcap library. Pcap (packet capture) is a portable API to capture network packet: it allows applications to capture packets at link-layer, bypassing the normal protocol stack. It also provides features like kernel-level packet filtering and access to internal statistics. Common applications include network statistics collection, security monitoring, network debugging, etc. =head1 NOTES =head2 Signals handling Since version 5.7.3, Perl uses a mechanism called "deferred signals" to delay signals delivery until "safe" points in the interpreter. See L for a detailed explanation. Since C version 0.08, released in October 2005, the module modified the internal variable C to re-enable immediate signals delivery in Perl 5.8 and later within some XS functions (CPAN-RT #6320). However, it can create situations where the Perl interpreter is less stable and can crash (CPAN-RT #43308). Therefore, as of version 0.17, C no longer modifies C by itself, but provides facilities so the user has full control of how signals are delivered. First, the C function allows one to select how signals are handled: pcap_perl_settings(PERL_SIGNALS_UNSAFE); pcap_loop($pcap, 10, \&process_packet, ""); pcap_perl_settings(PERL_SIGNALS_SAFE); Then, to easily make code interruptable, C provides the C pseudo-bloc: UNSAFE_SIGNALS { pcap_loop($pcap, 10, \&process_packet, ""); }; (Stolen from Rafael Garcia-Suarez's C) =head1 EXPORTS C supports the following C tags: =over =item * C<:bpf> exports a few BPF related constants: BPF_ALIGNMENT BPF_MAJOR_VERSION BPF_MAXBUFSIZE BPF_MAXINSNS BPF_MEMWORDS BPF_MINBUFSIZE BPF_MINOR_VERSION BPF_RELEASE =item * C<:datalink> exports the data link types macros: DLT_AIRONET_HEADER DLT_APPLE_IP_OVER_IEEE1394 DLT_ARCNET DLT_ARCNET_LINUX DLT_ATM_CLIP DLT_ATM_RFC1483 DLT_AURORA DLT_AX25 DLT_CHAOS DLT_CHDLC DLT_CISCO_IOS DLT_C_HDLC DLT_DOCSIS DLT_ECONET DLT_EN10MB DLT_EN3MB DLT_ENC DLT_FDDI DLT_FRELAY DLT_HHDLC DLT_IBM_SN DLT_IBM_SP DLT_IEEE802 DLT_IEEE802_11 DLT_IEEE802_11_RADIO DLT_IEEE802_11_RADIO_AVS DLT_IPFILTER DLT_IP_OVER_FC DLT_JUNIPER_ATM1 DLT_JUNIPER_ATM2 DLT_JUNIPER_ES DLT_JUNIPER_GGSN DLT_JUNIPER_MFR DLT_JUNIPER_MLFR DLT_JUNIPER_MLPPP DLT_JUNIPER_MONITOR DLT_JUNIPER_SERVICES DLT_LINUX_IRDA DLT_LINUX_SLL DLT_LOOP DLT_LTALK DLT_NULL DLT_OLD_PFLOG DLT_PCI_EXP DLT_PFLOG DLT_PFSYNC DLT_PPP DLT_PPP_BSDOS DLT_PPP_ETHER DLT_PPP_SERIAL DLT_PRISM_HEADER DLT_PRONET DLT_RAW DLT_RIO DLT_SLIP DLT_SLIP_BSDOS DLT_SUNATM DLT_SYMANTEC_FIREWALL DLT_TZSP DLT_USER0 DLT_USER1 DLT_USER2 DLT_USER3 DLT_USER4 DLT_USER5 DLT_USER6 DLT_USER7 DLT_USER8 DLT_USER9 DLT_USER10 DLT_USER11 DLT_USER12 DLT_USER13 DLT_USER14 DLT_USER15 =item * C<:pcap> exports the following C constants: PCAP_ERRBUF_SIZE PCAP_IF_LOOPBACK PCAP_VERSION_MAJOR PCAP_VERSION_MINOR =item * C<:mode> exports the following constants: MODE_CAPT MODE_MON MODE_STAT =item * C<:openflag> exports the following constants: OPENFLAG_PROMISCUOUS OPENFLAG_DATATX_UDP OPENFLAG_NOCAPTURE_RPCAP =item * C<:source> exports the following constants: PCAP_SRC_FILE PCAP_SRC_IFLOCAL PCAP_SRC_IFREMOTE =item * C<:sample> exports the following constants: PCAP_SAMP_NOSAMP PCAP_SAMP_1_EVERY_N PCAP_SAMP_FIRST_AFTER_N_MS =item * C<:rpcap> exports the following constants: RMTAUTH_NULL RMTAUTH_PWD =item * C<:functions> short names of the functions (without the C<"pcap_"> prefix) for those which would not cause a clash with an already defined name. Namely, the following functions are not available in short form: C, C, C, C, C, C. Using these short names is now discouraged, and may be removed in the future. =back By default, this module exports the symbols from the C<:datalink> and C<:pcap> tags, and all the functions, with the same names as the C library. =head1 FUNCTIONS All functions defined by C are direct mappings to the libpcap functions. Consult the pcap(3) documentation and source code for more information. Arguments that change a parameter, for example C, are passed that parameter as a reference. This is to retain compatibility with previous versions of C. =head2 Lookup functions =over =item B Returns the name of a network device that can be used with C function. On error, the C<$err> parameter is filled with an appropriate error message else it is undefined. B $dev = pcap_lookupdev(); =item B Returns a list of all network device names that can be used with C function. On error, the C<$err> parameter is filled with an appropriate error message else it is undefined. B @devs = pcap_findalldevs(\%devinfo, \$err); for my $dev (@devs) { print "$dev : $devinfo{$dev}\n" } =over =item B For backward compatibility reasons, this function can also be called using the following signatures: @devs = pcap_findalldevs(\$err); @devs = pcap_findalldevs(\$err, \%devinfo); The first form was introduced by Marco Carnut in C version 0.05 and kept intact in versions 0.06 and 0.07. The second form was introduced by Jean-Louis Morel for the Windows only, ActivePerl port of C, in versions 0.04.01 and 0.04.02. The new syntax has been introduced for consistency with the rest of the Perl API and the C API of C, where C<$err> is always the last argument. =back =item B Determine the network number and netmask for the device specified in C<$dev>. The function returns 0 on success and sets the C<$net> and C<$mask> parameters with values. On failure it returns -1 and the C<$err> parameter is filled with an appropriate error message. =back =head2 Packet capture functions =over =item B Returns a packet capture descriptor for looking at packets on the network. The C<$dev> parameter specifies which network interface to capture packets from. The C<$snaplen> and C<$promisc> parameters specify the maximum number of bytes to capture from each packet, and whether to put the interface into promiscuous mode, respectively. The C<$to_ms> parameter specifies a read timeout in milliseconds. The packet descriptor will be undefined if an error occurs, and the C<$err> parameter will be set with an appropriate error message. B $dev = pcap_lookupdev(); $pcap = pcap_open_live($dev, 1024, 1, 0, \$err) or die "Can't open device $dev: $err\n"; =item B Creates and returns a new packet descriptor to use when calling the other functions in C. It is typically used when just using C for compiling BPF code. B $pcap = pcap_open_dead(0, 1024); =item B Return a packet capture descriptor to read from a previously created "savefile". The returned descriptor is undefined if there was an error and in this case the C<$err> parameter will be filled. Savefiles are created using the C commands. B $pcap = pcap_open_offline($dump, \$err) or die "Can't read '$dump': $err\n"; =item B Read C<$count> packets from the packet capture descriptor C<$pcap> and call the perl function C<&callback> with an argument of C<$user_data>. If C<$count> is negative, then the function loops forever or until an error occurs. Returns 0 if C<$count> is exhausted, -1 on error, and -2 if the loop terminated due to a call to pcap_breakloop() before any packets were processed. The callback function is also passed packet header information and packet data like so: sub process_packet { my ($user_data, $header, $packet) = @_; ... } The header information is a reference to a hash containing the following fields. =over =item * C - the total length of the packet. =item * C - the actual captured length of the packet data. This corresponds to the snapshot length parameter passed to C. =item * C - seconds value of the packet timestamp. =item * C - microseconds value of the packet timestamp. =back B pcap_loop($pcap, 10, \&process_packet, "user data"); sub process_packet { my ($user_data, $header, $packet) = @_; # ... } =item B Sets a flag that will force C or C to return rather than looping; they will return the number of packets that have been processed so far, or -2 if no packets have been processed so far. This routine is safe to use inside a signal handler on UNIX or a console control handler on Windows, as it merely sets a flag that is checked within the loop. Please see the section on C in L for more information. =item B Close the packet capture device associated with the descriptor C<$pcap>. =item B Collect C<$count> packets and process them with callback function C<&callback>. if C<$count> is -1, all packets currently buffered are processed. If C<$count> is 0, process all packets until an error occurs. =item B Return the next available packet on the interface associated with packet descriptor C<$pcap>. Into the C<%header> hash is stored the received packet header. If not packet is available, the return value and header is undefined. =item B Reads the next available packet on the interface associated with packet descriptor C<$pcap>, stores its header in C<\%header> and its data in C<\$packet> and returns a success/failure indication: =over =item * C<1> means that the packet was read without problems; =item * C<0> means that packets are being read from a live capture, and the timeout expired; =item * C<-1> means that an error occurred while reading the packet; =item * C<-2> packets are being read from a dump file, and there are no more packets to read from the savefile. =back =item B Compile the filter string contained in C<$filter_str> and store it in C<$filter>. A description of the filter language can be found in the libpcap source code, or the manual page for tcpdump(8) . The filter is optimized if the C<$optimize> variable is true. The netmask of the network device must be specified in the C<$netmask> parameter. The function returns 0 if the compilation was successful, or -1 if there was a problem. =item B Similar to C except that instead of passing a C<$pcap> descriptor, one passes C<$snaplen> and C<$linktype> directly. Returns -1 if there was an error, but the error message is not available. =item B Associate the compiled filter stored in C<$filter> with the packet capture descriptor C<$pcap>. =item B Used to free the allocated memory used by a compiled filter, as created by C. =item B Check whether C<$filter> matches the packet described by header C<%header> and packet data C<$packet>. Returns true if the packet matches. =item B Set the I mode of a live capture descriptor, depending on the value of C<$mode> (zero to activate and non-zero to deactivate). It has no effect on offline descriptors. If there is an error, it returns -1 and sets C<$err>. In non-blocking mode, an attempt to read from the capture descriptor with C will, if no packets are currently available to be read, return 0 immediately rather than blocking waiting for packets to arrive. C and C will not work in non-blocking mode. =item B Returns the I state of the capture descriptor C<$pcap>. Always returns 0 on savefiles. If there is an error, it returns -1 and sets C<$err>. =back =head2 Savefile commands =over =item B Open a savefile for writing and return a descriptor for doing so. If C<$filename> is C<"-"> data is written to standard output. On error, the return value is undefined and C can be used to retrieve the error text. =item B Dump the packet described by header C<%header> and packet data C<$packet> to the savefile associated with C<$dumper>. The packet header has the same format as that passed to the C callback. B my $dump_file = 'network.dmp'; my $dev = pcap_lookupdev(); my $pcap = pcap_open_live($dev, 1024, 1, 0, \$err); my $dumper = pcap_dump_open($pcap, $dump_file); pcap_loop($pcap, 10, \&process_packet, ''); pcap_dump_close($dumper); sub process_packet { my ($user_data, $header, $packet) = @_; pcap_dump($dumper, $header, $packet); } =item B Returns the filehandle associated with a savefile opened with C. =item B Flushes the output buffer to the corresponding save file, so that any packets written with C but not yet written to the save file will be written. Returns -1 on error, 0 on success. =item B Close the savefile associated with the descriptor C<$dumper>. =back =head2 Status functions =over =item B Returns the link layer type associated with the given pcap descriptor. B $linktype = pcap_datalink($pcap); =item B Sets the data link type of the given pcap descriptor to the type specified by C<$linktype>. Returns -1 on failure. =item B Translates a data link type name, which is a C name with the C part removed, to the corresponding data link type value. The translation is case-insensitive. Returns -1 on failure. B $linktype = pcap_datalink_name_to_val('LTalk'); # returns DLT_LTALK =item B Translates a data link type value to the corresponding data link type name. B $name = pcap_datalink_val_to_name(DLT_LTALK); # returns 'LTALK' =item B Translates a data link type value to a short description of that data link type. B $descr = pcap_datalink_val_to_description(DLT_LTALK); # returns 'Localtalk' =item B Returns the snapshot length (snaplen) specified in the call to C. =item B This function returns true if the endianness of the currently open savefile is different from the endianness of the machine. =item B Return the major version number of the pcap library used to write the currently open savefile. =item B Return the minor version of the pcap library used to write the currently open savefile. =item B Returns a hash containing information about the status of packet capture device C<$pcap>. The hash contains the following fields. This function is supported only on live captures, not on savefiles; no statistics are stored in savefiles, so no statistics are available when reading from a savefile. =over =item * C - the number of packets received by the packet capture software. =item * C - the number of packets dropped by the packet capture software. =item * C - the number of packets dropped by the network interface. =back =item B Returns the filehandle associated with a savefile opened with C or C if the device was opened with C. =item B Returns the file number of the network device opened with C. =item B Returns, on Unix, a file descriptor number for a file descriptor on which one can do a C or C to wait for it to be possible to read packets without blocking, if such a descriptor exists, or -1, if no such descriptor exists. Some network devices opened with C do not support C or C, so -1 is returned for those devices. See L for more details. =back =head2 Error handling =over =item B Returns an error message for the last error associated with the packet capture device C<$pcap>. =item B Returns a string describing error number C<$errno>. =item B Prints the text of the last error associated with descriptor C<$pcap> on standard error, prefixed by C<$prefix>. =back =head2 Information =over =item B Returns the name and version of the C library the module was linked against. =back =head2 Perl specific functions The following functions are specific to the Perl binding of libpcap. =over =item B Modify internal behaviour of the Perl interpreter. =over =item * C, C respectively enable safe or unsafe signals delivery. Returns the previous value of C. See L<"Signals handling">. B local $SIG{ALRM} = sub { pcap_breakloop() }; alarm 60; pcap_perl_settings(PERL_SIGNALS_UNSAFE); pcap_loop($pcap, 10, \&process_packet, ""); pcap_perl_settings(PERL_SIGNALS_SAFE); =back =back =head2 WinPcap specific functions The following functions are only available with WinPcap, the Win32 port of the Pcap library. If a called function is not available, it will cleanly C. =over =item B Accepts a set of strings (host name, port, ...), and stores the complete source string according to the new format (e.g. C<"rpcap://1.2.3.4/eth0">) in C<$source>. This function is provided in order to help the user creating the source string according to the new format. An unique source string is used in order to make easy for old applications to use the remote facilities. Think about B, for example, which has only one way to specify the interface on which the capture has to be started. However, GUI-based programs can find more useful to specify hostname, port and interface name separately. In that case, they can use this function to create the source string before passing it to the C function. Returns 0 if everything is fine, -1 if some errors occurred. The string containing the complete source is returned in the C<$source> variable. =item B Parse the source string and stores the pieces in which the source can be split in the corresponding variables. This call is the other way round of C. It accepts a null-terminated string and it returns the parameters related to the source. This includes: =over =item * the type of the source (file, WinPcap on a remote adapter, WinPcap on local adapter), which is determined by the source prefix (C and so on); =item * the host on which the capture has to be started (only for remote captures); =item * the raw name of the source (file name, name of the remote adapter, name of the local adapter), without the source prefix. The string returned does not include the type of the source itself (i.e. the string returned does not include C<"file://"> or C<"rpcap://"> or such). =back The user can omit some parameters in case it is not interested in them. Returns 0 if everything is fine, -1 if some errors occurred. The requested values (host name, network port, type of the source) are returned into the proper variables passed by reference. =item B Open a generic source in order to capture / send (WinPcap only) traffic. The C replaces all the C functions with a single call. This function hides the differences between the different C functions so that the programmer does not have to manage different opening function. In this way, the I C function is decided according to the source type, which is included into the source string (in the form of source prefix). Returns a pointer to a pcap descriptor which can be used as a parameter to the following calls (C and so on) and that specifies an opened WinPcap session. In case of problems, it returns C and the C<$err> variable keeps the error message. =item B Sets the size of the kernel buffer associated with an adapter. C<$dim> specifies the size of the buffer in bytes. The return value is 0 when the call succeeds, -1 otherwise. If an old buffer was already created with a previous call to C, it is deleted and its content is discarded. C creates a S<1 MB> buffer by default. =item B Sets the working mode of the interface C<$pcap> to C<$mode>. Valid values for C<$mode> are C (default capture mode) and C (statistical mode). =item B Changes the minimum amount of data in the kernel buffer that causes a read from the application to return (unless the timeout expires). =item B Returns the C object associated with the interface C<$pcap>. Can be used to wait until the driver's buffer contains some data without performing a read. See L. =item B Send a raw packet to the network. C<$pcap> is the interface that will be used to send the packet, C<$packet> contains the data of the packet to send (including the various protocol headers). The MAC CRC doesn't need to be included, because it is transparently calculated and added by the network interface driver. The return value is 0 if the packet is successfully sent, -1 otherwise. =item B This function allocates and returns a send queue, i.e. a buffer containing a set of raw packets that will be transmitted on the network with C. C<$memsize> is the size, in bytes, of the queue, therefore it determines the maximum amount of data that the queue will contain. This memory is automatically deallocated when the queue ceases to exist. =item B Adds a packet at the end of the send queue pointed by C<$queue>. The packet header C<%header> has the same format as that passed to the C callback. C<$ackekt> is a buffer with the data of the packet. The C<%headerr> header structure is the same used by WinPcap and libpcap to store the packets in a file, therefore sending a capture file is straightforward. "Raw packet" means that the sending application will have to include the protocol headers, since every packet is sent to the network I. The CRC of the packets needs not to be calculated, because it will be transparently added by the network interface. =item B This function transmits the content of a queue to the wire. C<$pcapt> is the interface on which the packets will be sent, C<$queue> is to a C containing the packets to send, C<$sync> determines if the send operation must be synchronized: if it is non-zero, the packets are sent respecting the timestamps, otherwise they are sent as fast as possible. The return value is the amount of bytes actually sent. If it is smaller than the size parameter, an error occurred during the send. The error can be caused by a driver/adapter problem or by an inconsistent/bogus send queue. =back =head1 CONSTANTS C exports by default the names of several constants in order to ease the development of programs. See L for details about which constants are exported. Here are the descriptions of a few data link types. See L for a more complete description and semantics associated with each data link. =over =item * C - BSD loopback encapsulation =item * C - Ethernet (10Mb, 100Mb, 1000Mb, and up) =item * C - raw IP =item * C - IEEE 802.5 Token Ring =item * C - IEEE 802.11 wireless LAN =item * C - Frame Relay =item * C - FDDI =item * C - Serial Line IP =item * C - PPP (Point-to-point Protocol) =item * C - PPP over serial with HDLC encapsulation =item * C - PPP over Ethernet =item * C - RFC 2625 IP-over-Fibre Channel =item * C - Amateur Radio AX.25 =item * C - Linux-IrDA =item * C - Apple LocalTalk =item * C - Apple IP-over-IEEE 1394 (a.k.a. Firewire) =back =head1 DIAGNOSTICS =over =item C =item C =item C B<(F)> These errors occur if you forgot to give a reference to a function which expect one or more of its arguments to be references. =back =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. Currently known bugs: =over =item * the C field is not correctly set; see F =item * C seems to always returns C for live connection and causes segmentation fault for dump files; see F =item * C is documented to return -1 when called on save file, but seems to always return an actual file number. See F =item * C seems to corrupt something somewhere, and makes scripts dump core. See F =back =head1 EXAMPLES See the F and F directories of the C distribution for examples on using this module. =head1 SEE ALSO =head2 Perl Modules the L or L modules to assemble and disassemble packets. L for reassembly of TCP/IP fragments. L for using C within POE-based programs. L for using C within AnyEvent-based programs. L or L for decoding and creating network packets. L is a module which provides an easier, more Perl-ish API than C and integrates some facilities from L and L. =head2 Base Libraries L, L The source code for the C library is available from L The source code and binary for the Win32 version of the pcap library, WinPcap, is available from L =head2 Articles I, L I, L =head1 AUTHORS Current maintainer is SĂŠbastien Aperghis-Tramoni (SAPER) with the help of Tim Wilde (TWILDE). Complete list of authors & contributors: =over =item * Bo Adler (BOADLER) Ethumper (at) alumni.caltech.eduE =item * Craig Davison =item * David Farrell =item * David N. Blank-Edelman Ednb (at) ccs.neu.eduE =item * James Rouzier (ROUZIER) =item * Jean-Louis Morel (JLMOREL) Ejl_morel (at) bribes.orgE =item * Marco Carnut (KCARNUT) Ekiko (at) tempest.com.brE =item * Patrice Auffret (GOMOR) =item * Peter Lister (PLISTER) Ep.lister (at) cranfield.ac.ukE =item * RafaĂŤl Garcia-Suarez (RGARCIA) =item * SĂŠbastien Aperghis-Tramoni (SAPER) Esebastien (at) aperghis.netE =item * Tim Potter (TIMPOTTER) Etpot (at) frungy.orgE =item * Tim Wilde (TWILDE) =back =head1 HISTORY The original version of C, version 0.01, was written by Peter Lister using SWIG. Version 0.02 was created by Bo Adler with a few bugfixes but not uploaded to CPAN. It could be found at: L Versions 0.03 and 0.04 were created by Tim Potter who entirely rewrote C using XS and wrote the documentation, with the help of David N. Blank-Edelman for testing and general polishing. Version 0.05 was released by Marco Carnut with fixes to make it work with Cygwin and WinPcap. Version 0.04.02 was independently created by Jean-Louis Morel but not uploaded on the CPAN. It can be found here: L Based on Tim Potter's version 0.04, it included fixes for WinPcap and added wrappers for several new libpcap functions as well as WinPcap specific functions. =head1 ACKNOWLEDGEMENTS To Paul Johnson for his module L and his patience for helping me using it with XS code, which revealed very useful for writing more tests. To the beta-testers: Jean-Louis Morel, Max Maischen, Philippe Bruhat, David Morel, Scott Lanning, Rafael Garcia-Suarez, Karl Y. Pradene. =head1 COPYRIGHT & LICENSE Copyright (C) 2005-2016 SĂŠbastien Aperghis-Tramoni and contributors. All rights reserved. Copyright (C) 2003 Marco Carnut. All rights reserved. Copyright (C) 1999, 2000 Tim Potter. All rights reserved. Copyright (C) 1998 Bo Adler. All rights reserved. Copyright (C) 1997 Peter Lister. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Net-Pcap-0.21/META.json0000644000175000017500000000232414362166275014045 0ustar corioncorion{ "abstract" : "Interface to the pcap(3) LBL packet capture library", "author" : [ "Sebastien Aperghis-Tramoni " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-Pcap", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Socket" : "0", "Sys::Hostname" : "0", "Test::More" : "0.45", "XSLoader" : "0", "perl" : "5.006001" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/maddingue/Net-Pcap" } }, "version" : "0.21", "x_serialization_backend" : "JSON::PP version 4.11" } Net-Pcap-0.21/ppport.h0000644000175000017500000046204214362166261014123 0ustar corioncorion#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.14 Automatically created by Devel::PPPort running under perl 5.008006. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.14 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2008, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.14; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.011000| HeVAL||5.004000| HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.011000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.011000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofs_sv|||n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p POP_MULTICALL||5.011000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.011000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.011000||p aTHXR|5.011000||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fake||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| boot_core_xsutils||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lengthconst||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_retarget||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_ckproto||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.011000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| fd_on_nosuid_fs||| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_2pv||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags||5.009002| gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs||5.009003| gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUM||| isALPHA||| isDIGIT||| isLOWER||| isSPACE||| isUPPER||| is_an_int||| is_gv_magical_sv||| is_gv_magical||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| magicname||| make_matcher||| make_trie_failtable||| make_trie||| malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_linear_isa_c3||| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf||5.009003|vn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n my||| need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type||5.009005| newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsCV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.011000| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display||5.006000| pv_escape||5.009004| pv_pretty||5.009004| pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_stringify||5.009005| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem||5.004050| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv||5.007001| save_pptr||| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| setenv_getix||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.011000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (\$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif # define NUM2PTR(any,d) (any)(PTRV)(d) # define PTR2IV(p) INT2PTR(IV,p) # define PTR2UV(p) INT2PTR(UV,p) # define PTR2NV(p) NUM2PTR(NV,p) # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif /* !INT2PTR */ #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_laststatval laststatval # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting /* Replace: 0 */ #endif /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters * Do not use this variable. It is internal to the perl parser * and may change or even be removed in the future. Note that * as of perl 5.9.5 you cannot assign to this variable anymore. */ /* TODO: cannot assign to these vars; is it worth fixing? */ #if (PERL_BCDVERSION >= 0x5009005) # define PL_expect (PL_parser ? PL_parser->expect : 0) # define PL_copline (PL_parser ? PL_parser->copline : 0) # define PL_rsfp (PL_parser ? PL_parser->rsfp : (PerlIO *) 0) # define PL_rsfp_filters (PL_parser ? PL_parser->rsfp_filters : (AV *) 0) #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif /* Replace: 0 */ /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(s, len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval >= (int)len) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Net-Pcap-0.21/typemap0000644000175000017500000000122114362166261014014 0ustar corioncorion# # Map C types to Perl types # pcap_t * T_PTROBJ pcap_dumper_t * T_PTROBJ struct bpf_program * T_PTROBJ pcap_bpf_program_t * T_PTROBJ pcap_send_queue * T_PTROBJ bpf_u_int32 T_UV u_int T_UV u_char * T_PV const char * T_PV # # Input conversions # INPUT T_PTROBJ if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = ($type) tmp; } else croak(\"$var is not of type ${ntype}\") # # Output conversions # OUTPUT T_PTROBJ sv_setref_pv($arg, \"${ntype}\", (void*)$var); Net-Pcap-0.21/pcap_version.c0000644000175000017500000000016314362166261015252 0ustar corioncorion#include #include int main(int argc, char *argv[]) { printf("%s\n", pcap_lib_version()); } Net-Pcap-0.21/eg/0000755000175000017500000000000014362166275013016 5ustar corioncorionNet-Pcap-0.21/eg/pcapdump0000755000175000017500000001351414362166261014554 0ustar corioncorion#!/usr/bin/perl use strict; use Data::Hexdumper; use File::Basename; use Getopt::Long qw(:config no_auto_abbrev); use Net::Pcap qw(:functions); use NetPacket::Ethernet qw(:types); use NetPacket::IP qw(:protos); use NetPacket::TCP; use Pod::Usage; use Socket qw(inet_ntoa); $::PROGRAM = basename($0); $::VERSION = "0.01"; # globals my $dumper = undef; my %icmp = ( ICMP_ECHO => "echo", ICMP_ECHOREPLY => "echo-reply", ICMP_IREQ => "ireq", ICMP_IREQREPLY => "ireq-reply", ICMP_MASREQ => "mask", ICMP_MASKREPLY => "mask-reply", ICMP_PARAMPROB => "param-prob", ICMP_REDIRECT => "redirect", ICMP_ROUTERADVERT => "router-advert", ICMP_ROUTERSOLICIT => "router-solicit", ICMP_SOURCEQUENCH => "source-quench", ICMP_TIMXCEED => "time-exceeded", ICMP_TSTAMP => "timestamp", ICMP_TSTAMPREPLY => "timestamp-reply", ICMP_UNREACH => "unreachable", ); MAIN: { run(); } sub run { $|++; # get options my %options = ( count => 10, promisc => 0, snaplen => 256, timeout => 10, ); GetOptions(\%options, qw{ help|h! version|V! count|c=i interface|i=s promisc|p! snaplen|s=i writeto|w=s }) or pod2usage(); pod2usage({ -verbose => 2, -exitval => 0 }) if $options{help}; print "$::PROGRAM v$::VERSION\n" if $options{version}; my ($err, $net, $mask, $filter); my $dev = $options{interface} || pcap_lookupdev(\$err); my $filter_str = join " ", @ARGV; # open the interface my $pcap = pcap_open_live($dev, @options{qw(snaplen promisc timeout)}, \$err) or die "fatal: can't open network device $dev: $err ", "(do you have the privileges?)\n"; if ($filter_str) { # compile the filter pcap_compile($pcap, \$filter, $filter_str, 1, 0) == 0 or die "fatal: filter error\n"; pcap_setfilter($pcap, $filter); } if ($options{writeto}) { $dumper = pcap_dump_open($pcap, $options{writeto}) or die "fatal: can't write to file '$options{writeto}': $!\n"; } # print some information about the interface we're currently using pcap_lookupnet($dev, \$net, \$mask, \$err); print "listening on $dev (", dotquad($net), "/", dotquad($mask), ")", ", capture size $options{snaplen} bytes"; print ", filtering on $filter_str" if $filter_str; print $/; # enter the main loop pcap_loop($pcap, $options{count}, \&process_packet, ''); pcap_close($pcap); } sub process_packet { my ($user_data, $header, $packet) = @_; my ($proto, $payload, $src_ip, $src_port, $dest_ip, $dest_port, $flags); printf "packet: len=%s, caplen=%s, tv_sec=%s, tv_usec=%s\n", map { $header->{$_} } qw(len caplen tv_sec tv_usec); # dump the packet if asked to do so pcap_dump($dumper, $header, $packet) if $dumper; # decode the Ethernet frame my $ethframe = NetPacket::Ethernet->decode($packet); if ($ethframe->{type} == ETH_TYPE_IP) { # decode the IP payload my $ipframe = NetPacket::IP->decode($ethframe->{data}); $src_ip = $ipframe->{src_ip}; $dest_ip = $ipframe->{dest_ip}; if ($ipframe->{proto} == IP_PROTO_ICMP) { my $icmpframe = NetPacket::ICMP->decode($ipframe->{data}); $proto = "ICMP"; $payload = $icmpframe->{data}; } elsif ($ipframe->{proto} == IP_PROTO_TCP) { my $tcpframe = NetPacket::TCP->decode($ipframe->{data}); $proto = "TCP"; $src_port = $tcpframe->{src_port}; $dest_port = $tcpframe->{dest_port}; $payload = $tcpframe->{data}; $flags = flags_of($tcpframe->{flags}); } elsif ($ipframe->{proto} == IP_PROTO_UDP) { my $udpframe = NetPacket::UDP->decode($ipframe->{data}); $proto = "UDP"; $src_port = $udpframe->{src_port}; $dest_port = $udpframe->{dest_port}; $payload = $udpframe->{data}; } printf "IP:%s %s:%d -> %s:%d (%s)\n", $proto, $src_ip, $src_port, $dest_ip, $dest_port, $flags; print hexdump(data => $payload, start_position => 0) if length $payload; print $/; } } sub flags_of { my ($flags) = @_; my @strarr = (); push @strarr, "urg" if $flags & URG; push @strarr, "ack" if $flags & ACK; push @strarr, "psh" if $flags & PSH; push @strarr, "fin" if $flags & FIN; push @strarr, "syn" if $flags & SYN; push @strarr, "rst" if $flags & RST; push @strarr, "ece" if $flags & ECE; push @strarr, "cwr" if $flags & CWR; return join ",", @strarr } sub dotquad { return inet_ntoa( pack("I", $_[0]) ) } __END__ =head1 NAME pcapdump - Dump packets from the network =head1 SYNOPSIS pcapdump [-c count] [-i interface] [-s snaplen] [-w file] [expression] pcapdump --help pcapdump --version =head1 OPTIONS =over =item B<-c>, B<--count> I Exit after receiving I packets. =item B<-i>, B<--interface> I Listen on the specified interface. If unspecified, the program will use the interface returned by C. =item B<-s>, B<--snaplen> I Capture I bytes of data for each packet. Defaults to 256. =item B<-w>, B<--writeto> I =back =head1 DESCRIPTION B mimics the very basic features of B and provides a good example of how to use C. =head1 AUTHOR SEbastien Aperghis-Tramoni, Esebastien@aperghis.netE =head1 COPYRIGHT Copyright (C) 2005, 2006, 2007, 2008, 2009 SEbastien Aperghis-Tramoni. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Net-Pcap-0.21/eg/pktdump.pl0000644000175000017500000000210514362166261015030 0ustar corioncorion#!/usr/bin/perl use strict; use Getopt::Long qw(:config no_auto_abbrev); use Net::Pcap qw(:functions); $|=1; my %options = ( count => 10, promisc => 0, snaplen => 68, ); GetOptions(\%options, qw{ count|c=i interface|i=s promisc|p! snaplen|s=i writeto|w=s }) or die "usage: $0 [-c count] [-i interface] [-s snaplen] [-w file] [expression]\n"; my $err = ''; my $dev = $options{interface} || lookupdev(\$err); my $pcap = open_live($dev, $options{snaplen}, !$options{promisc}, 5, \$err) or die "fatal: can't open network device $dev: $! (do you have the privileges?)\n"; my $dumper; if ($options{writeto}) { $dumper = dump_open($pcap, $options{writeto}) or die "fatal: can't write to file '$options{writeto}': $!\n"; } loop($pcap, $options{count}, \&handle_packet, ''); pcap_close($pcap); sub handle_packet { my ($user_data, $header, $packet) = @_; printf "packet: len=%s, caplen=%s, tv_sec=%s, tv_usec=%s\n", map { $header->{$_} } qw(len caplen tv_sec tv_usec); pcap_dump($dumper, $header, $packet) if $options{writeto}; } Net-Pcap-0.21/stubs.inc0000644000175000017500000003574214362166261014264 0ustar corioncorion/* * stubs.inc - compatibility definitions to make this module compile in every cases * * Copyright (C) 2005, 2006 Sebastien Aperghis-Tramoni. All rights reserved. * * This program is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * */ /* Macros and constants */ #ifndef PCAP_BUF_SIZE #define PCAP_BUF_SIZE 1024 #endif #ifndef MODE_CAPT #define MODE_CAPT 0 #define MODE_STAT 1 #define MODE_MON 2 #endif #ifndef PCAP_SRC_FILE #define PCAP_SRC_FILE 2 #define PCAP_SRC_IFLOCAL 3 #define PCAP_SRC_IFREMOTE 4 #define PCAP_SRC_FILE_STRING "file://" #define PCAP_SRC_IF_STRING "rpcap://" #endif #ifndef PCAP_OPENFLAG_PROMISCUOUS #define PCAP_OPENFLAG_PROMISCUOUS 1 #define PCAP_OPENFLAG_DATATX_UDP 2 #define PCAP_OPENFLAG_NOCAPTURE_RPCAP 4 #endif #define OPENFLAG_PROMISCUOUS PCAP_OPENFLAG_PROMISCUOUS #define OPENFLAG_DATATX_UDP PCAP_OPENFLAG_DATATX_UDP #define OPENFLAG_NOCAPTURE_RPCAP PCAP_OPENFLAG_NOCAPTURE_RPCAP #ifndef PCAP_SAMP_NOSAMP #define PCAP_SAMP_NOSAMP 0 #define PCAP_SAMP_1_EVERY_N 1 #define PCAP_SAMP_FIRST_AFTER_N_MS 2 #endif #ifndef HANDLE #define HANDLE void * #endif #ifndef DWORD #define DWORD unsigned long #endif #ifndef SOCKET #ifdef WIN32 #define SOCKET unsigned int #else #define SOCKET int #endif #endif /* Stubs for functions not available in libpcap */ #define FUNCTION_NOT_IMPLEMENTED_ERROR(func) croak(\ "The function " #func "() is not available in your release of the pcap library."); #define FUNCTION_NOT_IMPLEMENTED_WARNING(func) warn(\ "The function " #func "() is not available in your release of the pcap library."); #ifndef HAVE_PCAP_LIB_VERSION #ifdef __GNUC__ #warning "the function pcap_lib_version() is not available, but will be emulated" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_lib_version() is not available, but will be emulated" ) #endif const char * pcap_lib_version(void); const char * pcap_lib_version(void) { return "libpcap version unknown (pre 0.8)"; } #endif #ifndef HAVE_PCAP_FINDALLDEVS #ifdef __GNUC__ #warning "the function pcap_findalldevs() is not available, but will be emulated" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_findalldevs() is not available, but will be emulated" ) #endif typedef struct pcap_if pcap_if_t; struct pcap_if { struct pcap_if *next; char *name; /* name to hand to "pcap_open_live()" */ char *description; /* textual description of interface, or NULL */ struct pcap_addr *addresses; bpf_u_int32 flags; /* PCAP_IF_ interface flags */ }; int pcap_findalldevs(pcap_if_t ** alldevsp, char * errbuf); int pcap_findalldevs(pcap_if_t ** alldevsp, char * errbuf) { return 3; } void pcap_freealldevs(pcap_if_t * alldevsp); void pcap_freealldevs(pcap_if_t * alldevsp) { return; } #endif #ifndef HAVE_PCAP_BREAKLOOP #ifdef __GNUC__ #warning "the function pcap_breakloop() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_breakloop() is not available" ) #endif void pcap_breakloop(pcap_t * p); void pcap_breakloop(pcap_t * p) { FUNCTION_NOT_IMPLEMENTED_WARNING(pcap_breakloop) } #endif #ifndef HAVE_PCAP_SETNONBLOCK #ifdef __GNUC__ #warning "the function pcap_setnonblock() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setnonblock() is not available" ) #endif int pcap_setnonblock(pcap_t * p, int nonblock, char * errbuf); int pcap_setnonblock(pcap_t * p, int nonblock, char * errbuf) { FUNCTION_NOT_IMPLEMENTED_WARNING(pcap_setnonblock) return -1; } #endif #ifndef HAVE_PCAP_GETNONBLOCK #ifdef __GNUC__ #warning "the function pcap_getnonblock() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_getnonblock() is not available" ) #endif int pcap_getnonblock(pcap_t * p, char * errbuf); int pcap_getnonblock(pcap_t * p, char * errbuf) { FUNCTION_NOT_IMPLEMENTED_WARNING(pcap_getnonblock) return -1; } #endif #ifndef HAVE_PCAP_DUMP_FILE #ifdef __GNUC__ #warning "the function pcap_dump_file() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_dump_file() is not available" ) #endif FILE *pcap_dump_file(pcap_dumper_t *p); FILE *pcap_dump_file(pcap_dumper_t *p) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_dump_file) return NULL; } #endif #ifndef HAVE_PCAP_DUMP_FLUSH #ifdef __GNUC__ #warning "the function pcap_dump_flush() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_dump_flush() is not available" ) #endif int pcap_dump_flush(pcap_dumper_t *p); int pcap_dump_flush(pcap_dumper_t *p) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_dump_flush) return -1; } #endif #ifndef HAVE_PCAP_LIST_DATALINKS #ifdef __GNUC__ #warning "the function pcap_list_datalinks() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_list_datalinks() is not available" ) #endif int pcap_list_datalinks(pcap_t *p, int **dlt_buf); int pcap_list_datalinks(pcap_t *p, int **dlt_buf) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_list_datalinks) return -1; } #endif #ifndef HAVE_PCAP_SET_DATALINK #ifdef __GNUC__ #warning "the function pcap_set_datalink() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_set_datalink() is not available" ) #endif int pcap_set_datalink(pcap_t * p, int datalink); int pcap_set_datalink(pcap_t * p, int datalink) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_set_datalink) return -1; } #endif #ifndef HAVE_PCAP_DATALINK_NAME_TO_VAL #ifdef __GNUC__ #warning "the function pcap_datalink_name_to_val() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_datalink_name_to_val() is not available" ) #endif int pcap_datalink_name_to_val(const char * name); int pcap_datalink_name_to_val(const char * name) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_datalink_name_to_val) return -1; } #endif #ifndef HAVE_PCAP_DATALINK_VAL_TO_NAME #ifdef __GNUC__ #warning "the function pcap_datalink_val_to_name() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_datalink_val_to_name() is not available" ) #endif const char * pcap_datalink_val_to_name(int datalink); const char * pcap_datalink_val_to_name(int datalink) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_datalink_val_to_name) return ""; } #endif #ifndef HAVE_PCAP_DATALINK_VAL_TO_DESCRIPTION #ifdef __GNUC__ #warning "the function pcap_datalink_val_to_description() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_datalink_val_to_description() is not available" ) #endif const char * pcap_datalink_val_to_description(int datalink); const char * pcap_datalink_val_to_description(int datalink) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_datalink_val_to_description) return ""; } #endif #ifndef HAVE_PCAP_COMPILE_NOPCAP #ifdef __GNUC__ #warning "the function pcap_compile_nopcap() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_compile_nopcap() is not available" ) #endif int pcap_compile_nopcap(int snaplen, int linktype, struct bpf_program *fp, char *str, int optimize, bpf_u_int32 netmask); int pcap_compile_nopcap(int snaplen, int linktype, struct bpf_program *fp, char *str, int optimize, bpf_u_int32 netmask) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_compile_nopcap) return -1; } #endif #ifndef HAVE_PCAP_GET_SELECTABLE_FD #ifdef __GNUC__ #warning "the function pcap_get_selectable_fd() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_get_selectable_fd() is not available" ) #endif int pcap_get_selectable_fd(pcap_t *p); int pcap_get_selectable_fd(pcap_t *p) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_get_selectable_fd) return -1; } #endif #ifndef HAVE_PCAP_NEXT_EX #ifdef __GNUC__ #warning "the function pcap_next_ex() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_next_ex() is not available" ) #endif int pcap_next_ex(pcap_t *p, struct pcap_pkthdr **pkt_header, const u_char **pkt_data); int pcap_next_ex(pcap_t *p, struct pcap_pkthdr **pkt_header, const u_char **pkt_data) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_next_ex) return -1; } #endif #ifndef HAVE_PCAP_SENDPACKET #ifdef __GNUC__ #warning "the function pcap_sendpacket() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_sendpacket() is not available" ) #endif int pcap_sendpacket(pcap_t *p, const u_char *buf, int size); int pcap_sendpacket(pcap_t *p, const u_char *buf, int size) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_sendpacket) return -1; } #endif #ifndef HAVE_PCAP_CREATESRCSTR #ifdef __GNUC__ #warning "the function pcap_createsrcstr() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_createsrcstr() is not available" ) #endif int pcap_createsrcstr(char *source, int type, const char *host, const char *port, const char *name, char *err); int pcap_createsrcstr(char *source, int type, const char *host, const char *port, const char *name, char *err) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_createsrcstr) return -1; } #endif #ifndef HAVE_PCAP_PARSESRCSTR #ifdef __GNUC__ #warning "the function pcap_parsesrcstr() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_parsesrcstr() is not available" ) #endif int pcap_parsesrcstr(const char *source, int *type, char *host, char *port, char *name, char *err); int pcap_parsesrcstr(const char *source, int *type, char *host, char *port, char *name, char *err) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_parsesrcstr) return -1; } #endif #ifndef HAVE_PCAP_OPEN #ifdef __GNUC__ #warning "the function pcap_open() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_open() is not available" ) #endif #if PERL_PCAP_VERSION < 1009000 struct pcap_rmtauth { int type; char *username; char *password; }; #endif pcap_t * pcap_open(const char *source, int snaplen, int flags, int read_timeout, struct pcap_rmtauth *auth, char *err); pcap_t * pcap_open(const char *source, int snaplen, int flags, int read_timeout, struct pcap_rmtauth *auth, char *err) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_open) return NULL; } #endif #ifndef HAVE_PCAP_SETBUFF #ifdef __GNUC__ #warning "the function pcap_setbuff() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setbuff() is not available" ) #endif int pcap_setbuff(pcap_t *p, int dim); int pcap_setbuff(pcap_t *p, int dim) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_setbuff) return -1; } #endif #ifndef HAVE_PCAP_SETUSERBUFFER #ifdef __GNUC__ #warning "the function pcap_setuserbuffer() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setuserbuffer() is not available" ) #endif int pcap_setuserbuffer(pcap_t *p, int size); int pcap_setuserbuffer(pcap_t *p, int size) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_setuserbuffer) return -1; } #endif #ifndef HAVE_PCAP_SETMODE #ifdef __GNUC__ #warning "the function pcap_setmode() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setmode() is not available" ) #endif int pcap_setmode(pcap_t *p, int mode); int pcap_setmode(pcap_t *p, int mode) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_setmode) return -1; } #endif #ifndef HAVE_PCAP_SETMINTOCOPY #ifdef __GNUC__ #warning "the function pcap_setmintocopy() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setmintocopy() is not available" ) #endif int pcap_setmintocopy(pcap_t *p, int size); int pcap_setmintocopy(pcap_t *p, int size) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_setmintocopy) return -1; } #endif #ifndef HAVE_PCAP_SENDQUEUE_ALLOC #ifdef __GNUC__ #warning "the function pcap_sendqueue_alloc() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_sendqueue_alloc() is not available" ) #endif struct pcap_send_queue{ u_int maxlen; u_int len; char *buffer; }; typedef struct pcap_send_queue pcap_send_queue; pcap_send_queue * pcap_sendqueue_alloc(u_int memsize); pcap_send_queue * pcap_sendqueue_alloc(u_int memsize) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_sendqueue_alloc) } #endif #ifndef HAVE_PCAP_SENDQUEUE_DESTROY #ifdef __GNUC__ #warning "the function pcap_sendqueue_destroy() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_sendqueue_destroy() is not available" ) #endif void pcap_sendqueue_destroy(pcap_send_queue *queue); void pcap_sendqueue_destroy(pcap_send_queue *queue) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_sendqueue_destroy) } #endif #ifndef HAVE_PCAP_SENDQUEUE_QUEUE #ifdef __GNUC__ #warning "the function pcap_sendqueue_queue() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_sendqueue_queue() is not available" ) #endif int pcap_sendqueue_queue(pcap_send_queue *queue, const struct pcap_pkthdr *pkt_header, const u_char *pkt_data); int pcap_sendqueue_queue(pcap_send_queue *queue, const struct pcap_pkthdr *pkt_header, const u_char *pkt_data) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_sendqueue_queue) return -1; } #endif #ifndef HAVE_PCAP_SENDQUEUE_TRANSMIT #ifdef __GNUC__ #warning "the function pcap_sendqueue_transmit() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_sendqueue_transmit() is not available" ) #endif u_int pcap_sendqueue_transmit(pcap_t *p, pcap_send_queue *queue, int sync); u_int pcap_sendqueue_transmit(pcap_t *p, pcap_send_queue *queue, int sync) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_sendqueue_transmit) return 0; } #endif #ifndef HAVE_PCAP_GETEVENT #ifdef __GNUC__ #warning "the function pcap_event() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_event() is not available" ) #endif HANDLE pcap_getevent(pcap_t *p); HANDLE pcap_getevent(pcap_t *p) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_event) return 0; } #endif #ifndef HAVE_PCAP_SETSAMPLING #ifdef __GNUC__ #warning "the function pcap_setsampling() is not available" #endif #ifdef _MSC_VER #pragma message( "Warning: the function pcap_setsampling() is not available" ) #endif #if PERL_PCAP_VERSION < 1009000 struct pcap_samp { int method; int value; }; #endif struct pcap_samp *pcap_setsampling(pcap_t *p); struct pcap_samp *pcap_setsampling(pcap_t *p) { FUNCTION_NOT_IMPLEMENTED_ERROR(pcap_setsampling) return NULL; } #endif /* int pcap_live_dump(pcap_t *p, char *filename, int maxsize, int maxpacks); int pcap_live_dump_ended(pcap_t *p, int sync); int pcap_offline_filter(struct bpf_program *prog, const struct pcap_pkthdr *header, const u_char *pkt_data); struct pcap_rmtauth { int type; char *username; char *password; }; SOCKET pcap_remoteact_accept(const char *address, const char *port, const char *hostlist, char *connectinghost, struct pcap_rmtauth *auth, char *errbuf); int pcap_remoteact_list(char *hostlist, char sep, int size, char *errbuf); int pcap_remoteact_close(const char *host, char *errbuf); void pcap_remoteact_cleanup(); */ Net-Pcap-0.21/Changes0000644000175000017500000002774214362166261013725 0ustar corioncorionThe revision history for Net-Pcap 0.21 - 2023-01-19 - Max Maischein (CORION) [Configure] - Avoid implicit ints during feature probing This is required for compatibility with future compilers as (for example) Fedora is moving to stricter C compiler versions. This is merely a cleanup of the C code probing for Pcap functionality, no need to upgrade. [Code] - use "our" for global variable declaration - Don't inherit from Exporter anymore This might break modules that rely on Net::Pcap isa Exporter, but that was never documented. 0.20 - 2021-12-17 - Max Maischein (CORION) [Bugfixes] - CPAN RT #118727 Spelling fixes Reported by Gregor Herrmann 0.19 - 2021-11-27 - Max Maischein (CORION) [Bugfixes] - CPAN RT #127685 Restore compilation with libpcap 1.9+ This incorporates the RedHat patch from https://www.cpan.org/authors/id/S/SR/SREZIC/patches/Net-Pcap-0.18-RT127685-RH1485429.patch and guards it with the newly introduced version #define - GH #9, CPAN RT #117831 , CPAN RT #125352 Too strict test for error message from libpcap Fix contributed by KENTNL 0.18 - 2016-05-15 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - CPAN RT #77807: Net::Pcap is no longer limited to one callback function, thanks to a patch by James Rouzier. [API] - Added pcap_offline_filter() (Martijn Lievaart). [Code] - use warnings (David Farrell). [Documentation] - CPAN RT #55163: Typo in eg/pcapdump (Iain Arnell and Jose Pedro Oliveira). - CPAN RT #83842: Typo in Net:Pcap (Xavier Guimard). - Moved HISTORY from README to main documentation. - Rewrote AUTHORS to acknowledge all contributors. - Updated copyright years. [Tests] - Added timeouts to prevent tests from hanging (Patrice Auffret). - t/17-lib_version.t: adjust regexp to match Apple builds (David Farrell). - t/50-poe-component-pcap.t: small improvments. - Added t/50-net-pcap-easy.t to test with Net::Pcap::Easy. - Added t/50-anyevent-pcap.t to test with AnyEvent::Pcap. - Make t/50-* pass with old versions of Test::More [Distribution] - Converted the Changes file to CPAN::Changes::Spec format. - Makefile.PL: append CCFLAGS to $Config{ccflags} instead of overriding it. - Makefile.PL: now dies when libpcap isn't found. - Makefile.PL: declare minimum Perl version (David Farrell). 0.17 - 2012-11-28 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - CPAN RT #43308: Net::Pcap no longer enables immediate (unsafe) signals delivery. - Fix allocated size in pcap_open(), pcap_createsrcstr() and pcap_parsesrcstr(). [API] - Now made the C-like API available by default. Added the pcap_perl_settings() function and UNSAFE_SIGNALS pseudo-bloc. [Code] - Replaced all occurrences of safemalloc() with Newx(). - Silenced some warnings. [Documentation] - Added a long note about Net::Pcap and signals delivery. - Improved README. - Mention Net::Pcap::Easy. [Tests] - Fixed t/17-lib_version.t to handle two digits versions. - CPAN RT #44448: Fixed t/17-lib_version.t to handle versions from CVS, thanks to Craig Davison. - Refactored t/01-api.t and added checks for the new API. - Replaced the fragile error check in t/03-openlive.t by a simpler and more robust one. 0.16 - 2008-01-01 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - A typo prevented the new function names from working. [Tests] - Added new tests: 21-next_ex.t, 22-open.t, 23-srcstr.t, 50-poe-component-pcap.t - Added support for user prefered device. See README. - Improved small bits of the tests here and there. 0.15 - 2007-12-02 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - CPAN RT #30745: Fix WinPcap support. - CPAN RT #25076: Fix next_ex(). [API] - Now providing "pcap_"-prefixed aliases for all functions. Documentation was changed to use these names instead of the old ones. [Commands] - pcapinfo(1) no longer need IO::Interface. [Documentation] - CPAN RT #27369: Several documentation fixes. - CPAN RT #31111: Document that pcap_stats() does not work on savefiles. [Tests] - CPAN RT #30903: Fix t/03-openlive.t failure on Linux. 0.15_01 - 2006-09-11 - Sebastien Aperghis-Tramoni (SAPER) [Documentation] - Improved documentation. [Tests] - Fixed small typo in warning message from t/podcover.t. Thanks to "Ani" on FreeNode. [Distribution] - Rewrote the functions detection code using DynaLoader. - Added example script eg/pktdump.pl 0.14 - 2006-09-05 - Sebastien Aperghis-Tramoni (SAPER) [Tests] - Bumped the required version of Test::Pod::Coverage up to 1.08. [Distribution] - CPAN RT #21219: Now use a default flag. 0.13 - 2006-08-29 - Sebastien Aperghis-Tramoni (SAPER) [Code] - Cleaned the typemap. Thanks to "Ani" on FreeNode for pointing. [Documentation] - Fixed small typo in README. Thanks to "Ani" on FreeNode. - Fixed small error in open_live() example. Thanks to Cindy Teel and Doug Baker. [Tests] - Fixed 05-dump.t, 10-fileno.t. Thanks to "Ani" on FreeNode. [Distribution] - Fixed compile option to use -Wall only for gcc. Thanks to Wolf-Dietrich Fromm for pointing. - Detection code can now handle IBM compiler. Thanks to Wolf-Dietrich Fromm for the help. 0.12 - 2006-03-19 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - Fixed stub for pcap_list_datalinks(). - Merged Jean-Louis Morel patch for Win32 and Cygwin. [Features] - Added wrappers for compile_nopcap(), get_selectable_fd(), next_ex() - Merged wrappers from Net::Pcap 0.04.02 for WinPcap functions createsrcstr(), parsesrcstr(), getevent(), open(), sendpacket(), sendqueue_alloc(), sendqueue_queue(), sendqueue_transmit(), setbuff(), setmintocopy(), setmode(). - Added wrapper for WinPcap function setuserbuffer(). [Code] - Added missing short names for compile(), set_filter(), freecode() [Tests] - Rewrote t/20-constants.t because future versions of ExtUtils::Constant will prevent the constant() function from being directly called. - Added t/22-open.t, t/23-strsrc.t - Updated t/03-openlive.t with diagnostics for FreeBSD and OpenBSD. [Distribution] - Fixed Makefile.PL so that pcapinfo is installed. 0.11 - 2005-11-28 - Sebastien Aperghis-Tramoni (SAPER) [Commands] - Added the pcapinfo command. [Documentation] - Corrected a few typos thanks to Test::Spelling. - Small documentation nits. [Tests] - Improved the whole test suite to make it use the best device it can find (was needed for Cygwin & Win32). [Distribution] - Cygwin installation was simplified and should now Just Work. 0.10 - 2005.11.01 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - lookupnet() wasn't exported by :functions. - Fixed findalldevs() emulation. - Replaced several newSViv() with newSVuv() to respect the actual unsigned nature of several fields. [Tests] - Fixed 03-openlive.t for Darwin/Mac OS X. - CPAN RT #15342: lookupnet() fails if the device returned by lookupdev() has no IP configured. Thanks to - CPAN RT #15343: warnings when running t/14-datalink.t - Fixed another corner case in t/02-lookup.t thanks to Rafael Garcia-Suarez. - t/Utils.pm now sets the environment locale to C. Thanks to Karl Y. Pradene. 0.09 - 2005-10-26 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - Restored compatibility with older versions of libpcap, namely the traditional ones founds on BSD systems. [Features] - Added Microsoft Visual C++ 7 compatibility, thanks to Max Maischen and Jean-Louis Morel. [Code] - Added new detection routines for looking which functions are actually available on the host system. - Upgraded to Devel::PPPort 3.06_03 [Tests] - Renamed t/CheckAuth.pm to t/Utils.pm, added function is_available(). - Changed the way the test utility module is loaded. - Updated several test files so they skip the tests that depend on a function that may be unavailable. - Fixes several corner cases thanks to the benevolent testing of Philippe Bruhat, David Morel and Scott Lanning. 0.08 - 2005-10-05 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - CPAN RT #6320: loop() conflicts with alarm(). Thanks to Rafaël Garcia-Suarez for the patch. Also applied to dispatch() and next(). - setnonblock() and getnonblock() now checks that $err is a reference. - Merged Jean-Louis Morel patch: modification of the detection code in Makefile.PL for Win32; fixes for compiling with Microsoft compiler; simplification of lookupdev(). - Restored compatibility with Perl 5.6, 5.5 and 5.4 - Fixed memory leak in lookupdev(). - Some XS wrappers (compile(), dispatch(), stats()) now resets the error string before calling the underlying functions. [Features] - Now tries to use XSLoader if available, then falls back to DynaLoader. - Improved findalldevs(). See documentation. - Added wrapper for freecode(), dump_flush(), dump_file(). [Tests] - Updated t/05-dump.t, t/12-next.t in order to increase code coverage (94%). What remains uncovered is cargo-cult defensive, hence untestable, code. - Updated t/01-api.t, t/05-dump.t, t/08-filter.t, t/10-fileno.t, t/13-dispatch.t, t/16-setnonblock.t - Updated all test scripts in order to suppress warnings. - Moved the the check whether pcap can be used in t/CheckAuth.pm and added Win32 specific code, supplied by Jean-Louis Morel. - Added t/rt-6320.t for checking the bugfix of CPAN RT #6320. - Added t/distchk.t [Distribution] - Improved detection code in Makefile.PL. 0.07 - 2005-09-23 - Sebastien Aperghis-Tramoni (SAPER) [Bugfixes] - CPAN RT #7455: Memory corruption when using Net::Pcap::Compile() - Merged Win32 fix to pcap_lookupdev() from JLM/0.04.02 [Features] - Added wrappers for lib_version(), open_dead(), set_datalink(), datalink_name_to_val(), datalink_val_to_name(), datalink_val_to_description() - Added support for all DLT_*, MODE_*, PCAP_* and useful BPF_* numeric macros using ExtUtils::Constant. - Added const qualifiers when appropriate. - Added ppport.h [Tests] - Fixed scripts t/10-fileno.t, - Added t/17-lib_version.t, t/18-open_dead.t, 19-breakloop.t - Updated t/14-datalink.t [Documentation] - Updated documentation. [Distribution] - Added libpcap detection using have_library() from XML::LibXML::Common 0.06 - 2005-09-15 - Sebastien Aperghis-Tramoni (SAPER) [Features] - CPAN RT #7594: added pcap_setnonblock() and pcap_getnonblock(). Thanks to Ernesto Domat for the patch. - Changed the warning returned by stats() in order to be uniform with other similar warnings [Documentation] - CPAN RT #7671: documentation typo - Updated the documentation. [Tests] - Completely rewrote the tests suite using Test::More and better (and portable) methods to skip tests when appropriate. - Added t/podcover.t, t/pod.t, t/portfs.t - Added t/15-is_swapped.t, t/16-setnonblock.t [Distribution] - Updated Makefile.PL 0.04.02 - 2003-09-03 - Jean-Louis Morel (JLMOREL) [based on 0.04, not released on CPAN] - includes fixes for WinPcap - added wrappers for several new libpcap functions - added several WinPcap specific functions 0.05 - 2003-06-16 - Marco Carnut (KCARNUT) - includes fixes for Cygwin and WinPcap (see http://winpcap.polito.it/ and install the SDK) - added wrapper for findalldevs() - lookupdev() returns the first item from findalldevs() - tests now pass under Cygwin by disabling the root user check 0.04 - 2000-05-17 - Tim Potter (TIMPOTTER) - now compiles and works with Perl 5.6.0 0.03 - 1999.03.24 - Tim Potter (TIMPOTTER) - complete rewrite using XS - all pcap library functions fully implemented - packet header and statistical information passed as Perl hashes - added Pod documentation 0.02 - 1998.12.06 - Bo Adler (BOADLER) [NOT RELEASED ON CPAN] - update to make it work with libpcap 0.4 - fixed problem in stats() method call - changed the arguments of the loop()/dispatch() callback to include the pcap_hdr struct 0.01 - 1997.08.27 - Peter Lister (PLISTER) - initial implementation using SWIG Net-Pcap-0.21/README0000644000175000017500000000757514362166261013314 0ustar corioncorionNAME Net::Pcap - Interface to pcap(3) LBL packet capture library DESCRIPTION The Net::Pcap module is a Perl binding to the LBL pcap(3) packet capture library. The latest source code for the Pcap library can be found at . The source code and binary for the Win32 port can be found at . INSTALLATION This module needs an ANSI-compliant compiler, the libpcap and its C headers to be installed on the target system. On many operating systems, simply install the "libpcap" and "libpcap-dev" packages. If the library and C headers are not installed in a standard location, please provide the appropriate paths to Makefile.PL using the INC and/or LIBS options: $ perl Makefile.PL INC=-I/opt/pcap/include \ LIBS='-L/opt/pcap/lib -lpcap' Then compile the extension as per usual: $ make all test $ make install To install the extension in a private directory, you can use the PREFIX option when creating Makefile.PL. For most of the tests, an administrative account is required since opening a network interface in promiscuous mode is a privileged operation. Some tests also require a working network interface with traffic on it otherwise the tests will appear to hang. You can generate traffic by pinging a non existing IP address on your network segment. Consult the source for individual tests for more information. You can select the interface Net::Pcap will use for its tests by creating a file device.txt in the distribution root directory and putting the device name inside. Net::Pcap is compatible with all the versions of the Pcap library, including the old BSD ones and the Windows port WinPcap. Net::Pcap should work on any Perl since 5.004_05. This module has been tested by the author on the following Perl and system versions but is likely to run on many more: Perl Architecture GCC Pcap ------------------------------------------------------------- 5.4.5 i686-linux 3.4.1 0.8.3 5.5.3 i686-linux 3.4.1 0.8.3 5.6.2 i686-linux 3.4.1 0.8.3 5.8.5 i386-linux-thread-multi 3.4.1 0.8.3 5.8.8 i486-linux-gnu-thread-multi 4.0.4 0.9.4 5.8.7 x86_64-linux 4.0.1 0.9.1 5.8.8 i386-freebsd-64int 3.4.4 0.9.1 5.8.6 darwin-thread-multi-2level (PowerPC) 4.0.1 For Perl 5.004, you may need to install ExtUtils::Constant with this patch: http://public.activestate.com/cgi-bin/perlbrowse?patch=25927 See also the corresponding CPAN Testers page: http://testers.cpan.org/show/Net-Pcap.html and the CPAN Testers Matrix: http://bbbike.radzeit.de/~slaven/cpantestersmatrix.cgi?dist=Net-Pcap SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Net::Pcap You can also look for information at: Meta::CPAN https://metacpan.org/dist/Net-Pcap CPAN Request Tracker: http://rt.cpan.org/Dist/Display.html?Name=Net-Pcap See also the examples scripts provided in the distribution, in the examples/ subdirectory. COPYRIGHT AND LICENCE Copyright (C) 2005-2016 Sebastien Aperghis-Tramoni and contributors. All rights reserved. Copyright (C) 2003 Marco Carnut. All rights reserved. Copyright (C) 1999-2000 Tim Potter. All rights reserved. Copyright (C) 1998 Bo Adler. All rights reserved. Copyright (C) 1997 Peter Lister. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-Pcap-0.21/MANIFEST0000644000175000017500000000167314362166261013556 0ustar corioncorion.gitignore bin/pcapinfo Changes eg/pcapdump eg/pktdump.pl fallback/const-c.inc fallback/const-xs.inc Makefile.PL MANIFEST MANIFEST.SKIP META.json META.yml Pcap.pm Pcap.xs pcap_version.c ppport.h README stubs.inc t/00-load.t t/01-api.t t/02-lookup.t t/03-openlive.t t/04-loop.t t/05-dump.t t/06-offline.t t/07-stats.t t/08-filter.t t/09-error.t t/10-fileno.t t/11-snapshot.t t/12-next.t t/13-dispatch.t t/14-datalink.t t/15-is_swapped.t t/16-setnonblock.t t/17-lib_version.t t/18-open_dead.t t/19-breakloop.t t/20-constants.t t/21-next_ex.t t/22-open.t t/23-srcstr.t t/24-offline_filter.t t/50-anyevent-pcap.t t/50-net-pcap-easy.t t/50-poe-component-pcap.t t/distchk.t t/leaktests/leaktest1.pl t/leaktests/leaktest2.pl t/leaktests/leaktest3.pl t/leaktests/leaktest4.pl t/leaktests/leaktest5.pl t/leaktests/leaktest6.pl t/pod.t t/podcover.t t/podspell.t t/portfs.t t/README t/samples/ping-ietf-20pk-be.dmp t/samples/ping-ietf-20pk-le.dmp t/Utils.pm typemap Net-Pcap-0.21/fallback/0000755000175000017500000000000014362166275014162 5ustar corioncorionNet-Pcap-0.21/fallback/const-xs.inc0000644000175000017500000000511414362166261016427 0ustar corioncorionvoid constant(sv) PREINIT: #ifdef dXSTARG dXSTARG; /* Faster if we have it. */ #else dTARGET; #endif STRLEN len; int type; IV iv; /* NV nv; Uncomment this if you need to return NVs */ /* const char *pv; Uncomment this if you need to return PVs */ INPUT: SV * sv; const char * s = SvPV(sv, len); PPCODE: /* Change this to constant(aTHX_ s, len, &iv, &nv); if you need to return both NVs and IVs */ type = constant(aTHX_ s, len, &iv); /* Return 1 or 2 items. First is error message, or undef if no error. Second, if present, is found value */ switch (type) { case PERL_constant_NOTFOUND: sv = sv_2mortal(newSVpvf("%s is not a valid pcap macro", s)); PUSHs(sv); break; case PERL_constant_NOTDEF: sv = sv_2mortal(newSVpvf( "Your vendor has not defined pcap macro %s, used", s)); PUSHs(sv); break; case PERL_constant_ISIV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHi(iv); break; /* Uncomment this if you need to return NOs case PERL_constant_ISNO: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(&PL_sv_no); break; */ /* Uncomment this if you need to return NVs case PERL_constant_ISNV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHn(nv); break; */ /* Uncomment this if you need to return PVs case PERL_constant_ISPV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHp(pv, strlen(pv)); break; */ /* Uncomment this if you need to return PVNs case PERL_constant_ISPVN: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHp(pv, iv); break; */ /* Uncomment this if you need to return SVs case PERL_constant_ISSV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(sv); break; */ /* Uncomment this if you need to return UNDEFs case PERL_constant_ISUNDEF: break; */ /* Uncomment this if you need to return UVs case PERL_constant_ISUV: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHu((UV)iv); break; */ /* Uncomment this if you need to return YESs case PERL_constant_ISYES: EXTEND(SP, 1); PUSHs(&PL_sv_undef); PUSHs(&PL_sv_yes); break; */ default: sv = sv_2mortal(newSVpvf( "Unexpected return type %d while processing pcap macro %s, used", type, s)); PUSHs(sv); } Net-Pcap-0.21/fallback/const-c.inc0000644000175000017500000011641714362166261016230 0ustar corioncorion#define PERL_constant_NOTFOUND 1 #define PERL_constant_NOTDEF 2 #define PERL_constant_ISIV 3 #define PERL_constant_ISNO 4 #define PERL_constant_ISNV 5 #define PERL_constant_ISPV 6 #define PERL_constant_ISPVN 7 #define PERL_constant_ISSV 8 #define PERL_constant_ISUNDEF 9 #define PERL_constant_ISUV 10 #define PERL_constant_ISYES 11 #ifndef NVTYPE typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ #endif #ifndef aTHX_ #define aTHX_ /* 5.6 or later define this for threading support. */ #endif #ifndef pTHX_ #define pTHX_ /* 5.6 or later define this for threading support. */ #endif static int constant_5 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_A BPF_B BPF_H BPF_K BPF_W BPF_X */ /* Offset 4 gives the best switch position. */ switch (name[4]) { case 'A': if (memEQ(name, "BPF_", 4)) { /* A */ #ifdef BPF_A *iv_return = BPF_A; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': if (memEQ(name, "BPF_", 4)) { /* B */ #ifdef BPF_B *iv_return = BPF_B; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'H': if (memEQ(name, "BPF_", 4)) { /* H */ #ifdef BPF_H *iv_return = BPF_H; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': if (memEQ(name, "BPF_", 4)) { /* K */ #ifdef BPF_K *iv_return = BPF_K; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'W': if (memEQ(name, "BPF_", 4)) { /* W */ #ifdef BPF_W *iv_return = BPF_W; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'X': if (memEQ(name, "BPF_", 4)) { /* X */ #ifdef BPF_X *iv_return = BPF_X; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_6 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_JA BPF_LD BPF_OR BPF_ST */ /* Offset 4 gives the best switch position. */ switch (name[4]) { case 'J': if (memEQ(name, "BPF_JA", 6)) { /* ^ */ #ifdef BPF_JA *iv_return = BPF_JA; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "BPF_LD", 6)) { /* ^ */ #ifdef BPF_LD *iv_return = BPF_LD; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'O': if (memEQ(name, "BPF_OR", 6)) { /* ^ */ #ifdef BPF_OR *iv_return = BPF_OR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "BPF_ST", 6)) { /* ^ */ #ifdef BPF_ST *iv_return = BPF_ST; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_7 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_ABS BPF_ADD BPF_ALU BPF_AND BPF_DIV BPF_IMM BPF_IND BPF_JEQ BPF_JGE BPF_JGT BPF_JMP BPF_LDX BPF_LEN BPF_LSH BPF_MEM BPF_MSH BPF_MUL BPF_NEG BPF_RET BPF_RSH BPF_STX BPF_SUB BPF_TAX BPF_TXA DLT_ENC DLT_PPP DLT_RAW DLT_RIO */ /* Offset 6 gives the best switch position. */ switch (name[6]) { case 'A': if (memEQ(name, "BPF_TX", 6)) { /* A */ #ifdef BPF_TXA *iv_return = BPF_TXA; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': if (memEQ(name, "BPF_SU", 6)) { /* B */ #ifdef BPF_SUB *iv_return = BPF_SUB; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'C': if (memEQ(name, "DLT_EN", 6)) { /* C */ #ifdef DLT_ENC *iv_return = DLT_ENC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'D': if (memEQ(name, "BPF_AD", 6)) { /* D */ #ifdef BPF_ADD *iv_return = BPF_ADD; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_AN", 6)) { /* D */ #ifdef BPF_AND *iv_return = BPF_AND; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_IN", 6)) { /* D */ #ifdef BPF_IND *iv_return = BPF_IND; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': if (memEQ(name, "BPF_JG", 6)) { /* E */ #ifdef BPF_JGE *iv_return = BPF_JGE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'G': if (memEQ(name, "BPF_NE", 6)) { /* G */ #ifdef BPF_NEG *iv_return = BPF_NEG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'H': if (memEQ(name, "BPF_LS", 6)) { /* H */ #ifdef BPF_LSH *iv_return = BPF_LSH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_MS", 6)) { /* H */ #ifdef BPF_MSH *iv_return = BPF_MSH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_RS", 6)) { /* H */ #ifdef BPF_RSH *iv_return = BPF_RSH; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "BPF_MU", 6)) { /* L */ #ifdef BPF_MUL *iv_return = BPF_MUL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'M': if (memEQ(name, "BPF_IM", 6)) { /* M */ #ifdef BPF_IMM *iv_return = BPF_IMM; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_ME", 6)) { /* M */ #ifdef BPF_MEM *iv_return = BPF_MEM; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'N': if (memEQ(name, "BPF_LE", 6)) { /* N */ #ifdef BPF_LEN *iv_return = BPF_LEN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'O': if (memEQ(name, "DLT_RI", 6)) { /* O */ #ifdef DLT_RIO *iv_return = DLT_RIO; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "BPF_JM", 6)) { /* P */ #ifdef BPF_JMP *iv_return = BPF_JMP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_PP", 6)) { /* P */ #ifdef DLT_PPP *iv_return = DLT_PPP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'Q': if (memEQ(name, "BPF_JE", 6)) { /* Q */ #ifdef BPF_JEQ *iv_return = BPF_JEQ; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "BPF_AB", 6)) { /* S */ #ifdef BPF_ABS *iv_return = BPF_ABS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "BPF_JG", 6)) { /* T */ #ifdef BPF_JGT *iv_return = BPF_JGT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_RE", 6)) { /* T */ #ifdef BPF_RET *iv_return = BPF_RET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'U': if (memEQ(name, "BPF_AL", 6)) { /* U */ #ifdef BPF_ALU *iv_return = BPF_ALU; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'V': if (memEQ(name, "BPF_DI", 6)) { /* V */ #ifdef BPF_DIV *iv_return = BPF_DIV; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'W': if (memEQ(name, "DLT_RA", 6)) { /* W */ #ifdef DLT_RAW *iv_return = DLT_RAW; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'X': if (memEQ(name, "BPF_LD", 6)) { /* X */ #ifdef BPF_LDX *iv_return = BPF_LDX; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_ST", 6)) { /* X */ #ifdef BPF_STX *iv_return = BPF_STX; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_TA", 6)) { /* X */ #ifdef BPF_TAX *iv_return = BPF_TAX; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_8 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_JSET BPF_MISC DLT_AX25 DLT_FDDI DLT_LOOP DLT_NULL DLT_SLIP DLT_TZSP MODE_MON */ /* Offset 5 gives the best switch position. */ switch (name[5]) { case 'D': if (memEQ(name, "DLT_FDDI", 8)) { /* ^ */ #ifdef DLT_FDDI *iv_return = DLT_FDDI; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "BPF_MISC", 8)) { /* ^ */ #ifdef BPF_MISC *iv_return = BPF_MISC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "DLT_SLIP", 8)) { /* ^ */ #ifdef DLT_SLIP *iv_return = DLT_SLIP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'M': if (memEQ(name, "MODE_MON", 8)) { /* ^ */ #ifdef MODE_MON *iv_return = MODE_MON; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'O': if (memEQ(name, "DLT_LOOP", 8)) { /* ^ */ #ifdef DLT_LOOP *iv_return = DLT_LOOP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "BPF_JSET", 8)) { /* ^ */ #ifdef BPF_JSET *iv_return = BPF_JSET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'U': if (memEQ(name, "DLT_NULL", 8)) { /* ^ */ #ifdef DLT_NULL *iv_return = DLT_NULL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'X': if (memEQ(name, "DLT_AX25", 8)) { /* ^ */ #ifdef DLT_AX25 *iv_return = DLT_AX25; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'Z': if (memEQ(name, "DLT_TZSP", 8)) { /* ^ */ #ifdef DLT_TZSP *iv_return = DLT_TZSP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_9 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. DLT_CHAOS DLT_CHDLC DLT_EN3MB DLT_HHDLC DLT_LTALK DLT_PFLOG DLT_USER0 DLT_USER1 DLT_USER2 DLT_USER3 DLT_USER4 DLT_USER5 DLT_USER6 DLT_USER7 DLT_USER8 DLT_USER9 MODE_CAPT MODE_STAT */ /* Offset 8 gives the best switch position. */ switch (name[8]) { case '0': if (memEQ(name, "DLT_USER", 8)) { /* 0 */ #ifdef DLT_USER0 *iv_return = DLT_USER0; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '1': if (memEQ(name, "DLT_USER", 8)) { /* 1 */ #ifdef DLT_USER1 *iv_return = DLT_USER1; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '2': if (memEQ(name, "DLT_USER", 8)) { /* 2 */ #ifdef DLT_USER2 *iv_return = DLT_USER2; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '3': if (memEQ(name, "DLT_USER", 8)) { /* 3 */ #ifdef DLT_USER3 *iv_return = DLT_USER3; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '4': if (memEQ(name, "DLT_USER", 8)) { /* 4 */ #ifdef DLT_USER4 *iv_return = DLT_USER4; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '5': if (memEQ(name, "DLT_USER", 8)) { /* 5 */ #ifdef DLT_USER5 *iv_return = DLT_USER5; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '6': if (memEQ(name, "DLT_USER", 8)) { /* 6 */ #ifdef DLT_USER6 *iv_return = DLT_USER6; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '7': if (memEQ(name, "DLT_USER", 8)) { /* 7 */ #ifdef DLT_USER7 *iv_return = DLT_USER7; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '8': if (memEQ(name, "DLT_USER", 8)) { /* 8 */ #ifdef DLT_USER8 *iv_return = DLT_USER8; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '9': if (memEQ(name, "DLT_USER", 8)) { /* 9 */ #ifdef DLT_USER9 *iv_return = DLT_USER9; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': if (memEQ(name, "DLT_EN3M", 8)) { /* B */ #ifdef DLT_EN3MB *iv_return = DLT_EN3MB; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'C': if (memEQ(name, "DLT_CHDL", 8)) { /* C */ #ifdef DLT_CHDLC *iv_return = DLT_CHDLC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_HHDL", 8)) { /* C */ #ifdef DLT_HHDLC *iv_return = DLT_HHDLC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'G': if (memEQ(name, "DLT_PFLO", 8)) { /* G */ #ifdef DLT_PFLOG *iv_return = DLT_PFLOG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'K': if (memEQ(name, "DLT_LTAL", 8)) { /* K */ #ifdef DLT_LTALK *iv_return = DLT_LTALK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "DLT_CHAO", 8)) { /* S */ #ifdef DLT_CHAOS *iv_return = DLT_CHAOS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "MODE_CAP", 8)) { /* T */ #ifdef MODE_CAPT *iv_return = MODE_CAPT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "MODE_STA", 8)) { /* T */ #ifdef MODE_STAT *iv_return = MODE_STAT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_10 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. DLT_ARCNET DLT_AURORA DLT_C_HDLC DLT_DOCSIS DLT_ECONET DLT_EN10MB DLT_FRELAY DLT_IBM_SN DLT_IBM_SP DLT_PFSYNC DLT_PRONET DLT_SUNATM DLT_USER10 DLT_USER11 DLT_USER12 DLT_USER13 DLT_USER14 DLT_USER15 */ /* Offset 9 gives the best switch position. */ switch (name[9]) { case '0': if (memEQ(name, "DLT_USER1", 9)) { /* 0 */ #ifdef DLT_USER10 *iv_return = DLT_USER10; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '1': if (memEQ(name, "DLT_USER1", 9)) { /* 1 */ #ifdef DLT_USER11 *iv_return = DLT_USER11; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '2': if (memEQ(name, "DLT_USER1", 9)) { /* 2 */ #ifdef DLT_USER12 *iv_return = DLT_USER12; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '3': if (memEQ(name, "DLT_USER1", 9)) { /* 3 */ #ifdef DLT_USER13 *iv_return = DLT_USER13; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '4': if (memEQ(name, "DLT_USER1", 9)) { /* 4 */ #ifdef DLT_USER14 *iv_return = DLT_USER14; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '5': if (memEQ(name, "DLT_USER1", 9)) { /* 5 */ #ifdef DLT_USER15 *iv_return = DLT_USER15; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'A': if (memEQ(name, "DLT_AUROR", 9)) { /* A */ #ifdef DLT_AURORA *iv_return = DLT_AURORA; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'B': if (memEQ(name, "DLT_EN10M", 9)) { /* B */ #ifdef DLT_EN10MB *iv_return = DLT_EN10MB; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'C': if (memEQ(name, "DLT_C_HDL", 9)) { /* C */ #ifdef DLT_C_HDLC *iv_return = DLT_C_HDLC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_PFSYN", 9)) { /* C */ #ifdef DLT_PFSYNC *iv_return = DLT_PFSYNC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'M': if (memEQ(name, "DLT_SUNAT", 9)) { /* M */ #ifdef DLT_SUNATM *iv_return = DLT_SUNATM; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'N': if (memEQ(name, "DLT_IBM_S", 9)) { /* N */ #ifdef DLT_IBM_SN *iv_return = DLT_IBM_SN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "DLT_IBM_S", 9)) { /* P */ #ifdef DLT_IBM_SP *iv_return = DLT_IBM_SP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "DLT_DOCSI", 9)) { /* S */ #ifdef DLT_DOCSIS *iv_return = DLT_DOCSIS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DLT_ARCNE", 9)) { /* T */ #ifdef DLT_ARCNET *iv_return = DLT_ARCNET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_ECONE", 9)) { /* T */ #ifdef DLT_ECONET *iv_return = DLT_ECONET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_PRONE", 9)) { /* T */ #ifdef DLT_PRONET *iv_return = DLT_PRONET; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'Y': if (memEQ(name, "DLT_FRELA", 9)) { /* Y */ #ifdef DLT_FRELAY *iv_return = DLT_FRELAY; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_11 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_RELEASE DLT_IEEE802 DLT_PCI_EXP */ /* Offset 6 gives the best switch position. */ switch (name[6]) { case 'E': if (memEQ(name, "DLT_IEEE802", 11)) { /* ^ */ #ifdef DLT_IEEE802 *iv_return = DLT_IEEE802; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "DLT_PCI_EXP", 11)) { /* ^ */ #ifdef DLT_PCI_EXP *iv_return = DLT_PCI_EXP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "BPF_RELEASE", 11)) { /* ^ */ #ifdef BPF_RELEASE *iv_return = BPF_RELEASE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_12 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_MAXINSNS BPF_MEMWORDS DLT_ATM_CLIP DLT_IPFILTER */ /* Offset 9 gives the best switch position. */ switch (name[9]) { case 'L': if (memEQ(name, "DLT_ATM_CLIP", 12)) { /* ^ */ #ifdef DLT_ATM_CLIP *iv_return = DLT_ATM_CLIP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'R': if (memEQ(name, "BPF_MEMWORDS", 12)) { /* ^ */ #ifdef BPF_MEMWORDS *iv_return = BPF_MEMWORDS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "BPF_MAXINSNS", 12)) { /* ^ */ #ifdef BPF_MAXINSNS *iv_return = BPF_MAXINSNS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DLT_IPFILTER", 12)) { /* ^ */ #ifdef DLT_IPFILTER *iv_return = DLT_IPFILTER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_13 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_ALIGNMENT DLT_CISCO_IOS DLT_LINUX_SLL DLT_OLD_PFLOG DLT_PPP_BSDOS DLT_PPP_ETHER */ /* Offset 10 gives the best switch position. */ switch (name[10]) { case 'D': if (memEQ(name, "DLT_PPP_BSDOS", 13)) { /* ^ */ #ifdef DLT_PPP_BSDOS *iv_return = DLT_PPP_BSDOS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': if (memEQ(name, "BPF_ALIGNMENT", 13)) { /* ^ */ #ifdef BPF_ALIGNMENT *iv_return = BPF_ALIGNMENT; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'H': if (memEQ(name, "DLT_PPP_ETHER", 13)) { /* ^ */ #ifdef DLT_PPP_ETHER *iv_return = DLT_PPP_ETHER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "DLT_CISCO_IOS", 13)) { /* ^ */ #ifdef DLT_CISCO_IOS *iv_return = DLT_CISCO_IOS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "DLT_OLD_PFLOG", 13)) { /* ^ */ #ifdef DLT_OLD_PFLOG *iv_return = DLT_OLD_PFLOG; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'S': if (memEQ(name, "DLT_LINUX_SLL", 13)) { /* ^ */ #ifdef DLT_LINUX_SLL *iv_return = DLT_LINUX_SLL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_14 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_MAXBUFSIZE BPF_MINBUFSIZE DLT_IEEE802_11 DLT_IP_OVER_FC DLT_JUNIPER_ES DLT_LINUX_IRDA DLT_PPP_SERIAL DLT_SLIP_BSDOS */ /* Offset 7 gives the best switch position. */ switch (name[7]) { case 'B': if (memEQ(name, "BPF_MAXBUFSIZE", 14)) { /* ^ */ #ifdef BPF_MAXBUFSIZE *iv_return = BPF_MAXBUFSIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "BPF_MINBUFSIZE", 14)) { /* ^ */ #ifdef BPF_MINBUFSIZE *iv_return = BPF_MINBUFSIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'E': if (memEQ(name, "DLT_IEEE802_11", 14)) { /* ^ */ #ifdef DLT_IEEE802_11 *iv_return = DLT_IEEE802_11; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "DLT_JUNIPER_ES", 14)) { /* ^ */ #ifdef DLT_JUNIPER_ES *iv_return = DLT_JUNIPER_ES; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'O': if (memEQ(name, "DLT_IP_OVER_FC", 14)) { /* ^ */ #ifdef DLT_IP_OVER_FC *iv_return = DLT_IP_OVER_FC; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'P': if (memEQ(name, "DLT_SLIP_BSDOS", 14)) { /* ^ */ #ifdef DLT_SLIP_BSDOS *iv_return = DLT_SLIP_BSDOS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'U': if (memEQ(name, "DLT_LINUX_IRDA", 14)) { /* ^ */ #ifdef DLT_LINUX_IRDA *iv_return = DLT_LINUX_IRDA; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case '_': if (memEQ(name, "DLT_PPP_SERIAL", 14)) { /* ^ */ #ifdef DLT_PPP_SERIAL *iv_return = DLT_PPP_SERIAL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_16 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. DLT_ARCNET_LINUX DLT_JUNIPER_ATM1 DLT_JUNIPER_ATM2 DLT_JUNIPER_GGSN DLT_JUNIPER_MLFR DLT_PRISM_HEADER PCAP_ERRBUF_SIZE PCAP_IF_LOOPBACK */ /* Offset 13 gives the best switch position. */ switch (name[13]) { case 'A': if (memEQ(name, "PCAP_IF_LOOPBACK", 16)) { /* ^ */ #ifdef PCAP_IF_LOOPBACK *iv_return = PCAP_IF_LOOPBACK; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'D': if (memEQ(name, "DLT_PRISM_HEADER", 16)) { /* ^ */ #ifdef DLT_PRISM_HEADER *iv_return = DLT_PRISM_HEADER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'G': if (memEQ(name, "DLT_JUNIPER_GGSN", 16)) { /* ^ */ #ifdef DLT_JUNIPER_GGSN *iv_return = DLT_JUNIPER_GGSN; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "PCAP_ERRBUF_SIZE", 16)) { /* ^ */ #ifdef PCAP_ERRBUF_SIZE *iv_return = PCAP_ERRBUF_SIZE; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'L': if (memEQ(name, "DLT_JUNIPER_MLFR", 16)) { /* ^ */ #ifdef DLT_JUNIPER_MLFR *iv_return = DLT_JUNIPER_MLFR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'N': if (memEQ(name, "DLT_ARCNET_LINUX", 16)) { /* ^ */ #ifdef DLT_ARCNET_LINUX *iv_return = DLT_ARCNET_LINUX; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'T': if (memEQ(name, "DLT_JUNIPER_ATM1", 16)) { /* ^ */ #ifdef DLT_JUNIPER_ATM1 *iv_return = DLT_JUNIPER_ATM1; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } if (memEQ(name, "DLT_JUNIPER_ATM2", 16)) { /* ^ */ #ifdef DLT_JUNIPER_ATM2 *iv_return = DLT_JUNIPER_ATM2; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_17 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. BPF_MAJOR_VERSION BPF_MINOR_VERSION DLT_JUNIPER_MLPPP */ /* Offset 5 gives the best switch position. */ switch (name[5]) { case 'A': if (memEQ(name, "BPF_MAJOR_VERSION", 17)) { /* ^ */ #ifdef BPF_MAJOR_VERSION *iv_return = BPF_MAJOR_VERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'I': if (memEQ(name, "BPF_MINOR_VERSION", 17)) { /* ^ */ #ifdef BPF_MINOR_VERSION *iv_return = BPF_MINOR_VERSION; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'U': if (memEQ(name, "DLT_JUNIPER_MLPPP", 17)) { /* ^ */ #ifdef DLT_JUNIPER_MLPPP *iv_return = DLT_JUNIPER_MLPPP; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant_18 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. DLT_AIRONET_HEADER PCAP_VERSION_MAJOR PCAP_VERSION_MINOR */ /* Offset 15 gives the best switch position. */ switch (name[15]) { case 'D': if (memEQ(name, "DLT_AIRONET_HEADER", 18)) { /* ^ */ #ifdef DLT_AIRONET_HEADER *iv_return = DLT_AIRONET_HEADER; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'J': if (memEQ(name, "PCAP_VERSION_MAJOR", 18)) { /* ^ */ #ifdef PCAP_VERSION_MAJOR *iv_return = PCAP_VERSION_MAJOR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'N': if (memEQ(name, "PCAP_VERSION_MINOR", 18)) { /* ^ */ #ifdef PCAP_VERSION_MINOR *iv_return = PCAP_VERSION_MINOR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } static int constant (pTHX_ const char *name, STRLEN len, IV *iv_return) { /* Initially switch on the length of the name. */ /* When generated this function returned values for the list of names given in this section of perl code. Rather than manually editing these functions to add or remove constants, which would result in this comment and section of code becoming inaccurate, we recommend that you edit this section of code, and use it to regenerate a new set of constant functions which you then use to replace the originals. Regenerate these constant functions by feeding this entire source file to perl -x #!/usr/bin/perl5.8.5 -w use ExtUtils::Constant qw (constant_types C_constant XS_constant); my $types = {map {($_, 1)} qw(IV)}; my @names = (qw(BPF_A BPF_ABS BPF_ADD BPF_ALIGNMENT BPF_ALU BPF_AND BPF_B BPF_DIV BPF_H BPF_IMM BPF_IND BPF_JA BPF_JEQ BPF_JGE BPF_JGT BPF_JMP BPF_JSET BPF_K BPF_LD BPF_LDX BPF_LEN BPF_LSH BPF_MAJOR_VERSION BPF_MAXBUFSIZE BPF_MAXINSNS BPF_MEM BPF_MEMWORDS BPF_MINBUFSIZE BPF_MINOR_VERSION BPF_MISC BPF_MSH BPF_MUL BPF_NEG BPF_OR BPF_RELEASE BPF_RET BPF_RSH BPF_ST BPF_STX BPF_SUB BPF_TAX BPF_TXA BPF_W BPF_X DLT_AIRONET_HEADER DLT_APPLE_IP_OVER_IEEE1394 DLT_ARCNET DLT_ARCNET_LINUX DLT_ATM_CLIP DLT_ATM_RFC1483 DLT_AURORA DLT_AX25 DLT_CHAOS DLT_CHDLC DLT_CISCO_IOS DLT_C_HDLC DLT_DOCSIS DLT_ECONET DLT_EN10MB DLT_EN3MB DLT_ENC DLT_FDDI DLT_FRELAY DLT_HHDLC DLT_IBM_SN DLT_IBM_SP DLT_IEEE802 DLT_IEEE802_11 DLT_IEEE802_11_RADIO DLT_IEEE802_11_RADIO_AVS DLT_IPFILTER DLT_IP_OVER_FC DLT_JUNIPER_ATM1 DLT_JUNIPER_ATM2 DLT_JUNIPER_ES DLT_JUNIPER_GGSN DLT_JUNIPER_MFR DLT_JUNIPER_MLFR DLT_JUNIPER_MLPPP DLT_JUNIPER_MONITOR DLT_JUNIPER_SERVICES DLT_LINUX_IRDA DLT_LINUX_SLL DLT_LOOP DLT_LTALK DLT_NULL DLT_OLD_PFLOG DLT_PCI_EXP DLT_PFLOG DLT_PFSYNC DLT_PPP DLT_PPP_BSDOS DLT_PPP_ETHER DLT_PPP_SERIAL DLT_PRISM_HEADER DLT_PRONET DLT_RAW DLT_RIO DLT_SLIP DLT_SLIP_BSDOS DLT_SUNATM DLT_SYMANTEC_FIREWALL DLT_TZSP DLT_USER0 DLT_USER1 DLT_USER10 DLT_USER11 DLT_USER12 DLT_USER13 DLT_USER14 DLT_USER15 DLT_USER2 DLT_USER3 DLT_USER4 DLT_USER5 DLT_USER6 DLT_USER7 DLT_USER8 DLT_USER9 MODE_CAPT MODE_MON MODE_STAT PCAP_ERRBUF_SIZE PCAP_IF_LOOPBACK PCAP_VERSION_MAJOR PCAP_VERSION_MINOR)); print constant_types(); # macro defs foreach (C_constant ("pcap", 'constant', 'IV', $types, undef, 3, @names) ) { print $_, "\n"; # C constant subs } print "#### XS Section:\n"; print XS_constant ("pcap", $types); __END__ */ switch (len) { case 5: return constant_5 (aTHX_ name, iv_return); break; case 6: return constant_6 (aTHX_ name, iv_return); break; case 7: return constant_7 (aTHX_ name, iv_return); break; case 8: return constant_8 (aTHX_ name, iv_return); break; case 9: return constant_9 (aTHX_ name, iv_return); break; case 10: return constant_10 (aTHX_ name, iv_return); break; case 11: return constant_11 (aTHX_ name, iv_return); break; case 12: return constant_12 (aTHX_ name, iv_return); break; case 13: return constant_13 (aTHX_ name, iv_return); break; case 14: return constant_14 (aTHX_ name, iv_return); break; case 15: /* Names all of length 15. */ /* DLT_ATM_RFC1483 DLT_JUNIPER_MFR */ /* Offset 5 gives the best switch position. */ switch (name[5]) { case 'T': if (memEQ(name, "DLT_ATM_RFC1483", 15)) { /* ^ */ #ifdef DLT_ATM_RFC1483 *iv_return = DLT_ATM_RFC1483; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'U': if (memEQ(name, "DLT_JUNIPER_MFR", 15)) { /* ^ */ #ifdef DLT_JUNIPER_MFR *iv_return = DLT_JUNIPER_MFR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; case 16: return constant_16 (aTHX_ name, iv_return); break; case 17: return constant_17 (aTHX_ name, iv_return); break; case 18: return constant_18 (aTHX_ name, iv_return); break; case 19: if (memEQ(name, "DLT_JUNIPER_MONITOR", 19)) { #ifdef DLT_JUNIPER_MONITOR *iv_return = DLT_JUNIPER_MONITOR; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 20: /* Names all of length 20. */ /* DLT_IEEE802_11_RADIO DLT_JUNIPER_SERVICES */ /* Offset 4 gives the best switch position. */ switch (name[4]) { case 'I': if (memEQ(name, "DLT_IEEE802_11_RADIO", 20)) { /* ^ */ #ifdef DLT_IEEE802_11_RADIO *iv_return = DLT_IEEE802_11_RADIO; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 'J': if (memEQ(name, "DLT_JUNIPER_SERVICES", 20)) { /* ^ */ #ifdef DLT_JUNIPER_SERVICES *iv_return = DLT_JUNIPER_SERVICES; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } break; case 21: if (memEQ(name, "DLT_SYMANTEC_FIREWALL", 21)) { #ifdef DLT_SYMANTEC_FIREWALL *iv_return = DLT_SYMANTEC_FIREWALL; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 24: if (memEQ(name, "DLT_IEEE802_11_RADIO_AVS", 24)) { #ifdef DLT_IEEE802_11_RADIO_AVS *iv_return = DLT_IEEE802_11_RADIO_AVS; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; case 26: if (memEQ(name, "DLT_APPLE_IP_OVER_IEEE1394", 26)) { #ifdef DLT_APPLE_IP_OVER_IEEE1394 *iv_return = DLT_APPLE_IP_OVER_IEEE1394; return PERL_constant_ISIV; #else return PERL_constant_NOTDEF; #endif } break; } return PERL_constant_NOTFOUND; } Net-Pcap-0.21/bin/0000755000175000017500000000000014362166275013173 5ustar corioncorionNet-Pcap-0.21/bin/pcapinfo0000755000175000017500000001062514362166261014717 0ustar corioncorion#!/usr/bin/perl use strict; use warnings; use Net::Pcap ':functions'; use Sys::Hostname; my $has_io_interface = eval "use IO::Interface::Simple ':flags'; 1" || 0; my(%devs, $err) = (); my @devs = findalldevs(\%devs, \$err); my $hostname = hostname(); my $aliases = (gethostbyname($hostname))[1]; print "Host information\n", "----------------\n", " Hostname : $hostname\n"; print " Aliases : $aliases\n" if $aliases; print " Pcap version : ", lib_version(), $/, $/, "Devices information\n", "-------------------\n"; for my $dev (@devs) { my $default = $dev eq lookupdev(\$err) ? "(default)" : ''; print "Device $dev $default\n", " Description : $devs{$dev}\n"; print " Link type : ", linktype($dev), $/ if $dev ne "any"; if ($has_io_interface) { my $iface = IO::Interface::Simple->new($dev); if (defined $iface) { print " Hardware address : ", $iface->hwaddr, $/ if $iface->hwaddr; print " Network address : ", $iface->address, $/ if $iface->address; print " Network mask : ", $iface->netmask, $/ if $iface->netmask; print " Flags : ", flags($iface), $/; } } print $/; } sub linktype { my ($dev) = @_; my $linktype = ""; my $status = ""; if (my $pcap = open_live($dev, 1024, 1, 0, \$err)) { $linktype = datalink_val_to_description(datalink($pcap)); pcap_close($pcap); } if (-e "/sbin/mii-tool") { chomp($status = `/sbin/mii-tool $dev 2>/dev/null`); $status =~ s/$dev\:/,/; } return $linktype . $status } sub flags { my ($iface) = @_; my $string = ''; $string .= "up " if $iface->flags & &IO::Interface::IFF_UP; $string .= "running " if $iface->is_running; $string .= "broadcast " if $iface->is_broadcast; $string .= "debug " if $iface->flags & &IO::Interface::IFF_DEBUG; $string .= "loopback " if $iface->is_loopback; $string .= "p-to-p " if $iface->is_pt2pt; $string .= "notrailers " if $iface->is_notrailers; $string .= "noarp " if $iface->is_noarp; $string .= "promiscuous " if $iface->is_promiscuous; $string .= "multicast " if $iface->is_multicast; $string .= "allmulti " if $iface->flags & eval { &IO::Interface::IFF_ALLMULTI }; $string .= "master " if $iface->flags & eval { &IO::Interface::IFF_MASTER }; $string .= "slave " if $iface->flags & eval { &IO::Interface::IFF_SLAVE }; $string .= "portsel " if $iface->flags & eval { &IO::Interface::IFF_PORTSEL }; $string .= "automedia " if $iface->flags & eval { &IO::Interface::IFF_AUTOMEDIA }; return $string } __END__ =head1 NAME pcapinfo - Prints detailed information about the network devices =head1 SYNOPSIS pcapinfo =head1 OPTIONS None. =head1 DESCRIPTION B prints detailed information about the network devices and Pcap library available on the current host. Here is an example: Host information ---------------- Hostname : fangorn.maddingue.net Aliases : fangorn.local fangorn Pcap version : libpcap version 0.8.3 Devices information ------------------- Device eth0 (default) Description : No description available Link type : Ethernet, no autonegotiation, 10baseT-HD, link ok Hardware address : 00:0c:6e:0a:c3:ca Network address : 10.0.1.51 Network mask : 255.255.255.0 Flags : up running broadcast multicast Device eth1 Description : No description available Link type : Ethernet, no autonegotiation, 10baseT-HD, link ok Hardware address : 00:26:54:0a:d8:4d Network address : 192.168.1.51 Network mask : 255.255.255.0 Flags : up running broadcast multicast The device marked as C<"(default)"> is the one returned when calling C Some information like the link type can only be gathered with administrative privileges. =head1 AUTHOR SEbastien Aperghis-Tramoni, Esebastien@aperghis.netE =head1 COPYRIGHT Copyright (C) 2005, 2006, 2007, 2008, 2009 SEbastien Aperghis-Tramoni. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut