โอ้ใช่คุณสามารถใช้ Regexes เพื่อแยกวิเคราะห์ HTML!
สำหรับงานที่คุณพยายาม regexes ก็ดีมาก!
มันเป็นความจริงที่คนส่วนใหญ่ดูถูกดูแคลนความยากลำบากในการแยกวิเคราะห์ HTML ด้วยการแสดงออกปกติและทำไม่ดี
แต่นี่ไม่ใช่ข้อบกพร่องพื้นฐานที่เกี่ยวข้องกับทฤษฎีการคำนวณ ความโง่เขลานั้นมีอยู่มากมายที่นี่แต่คุณไม่เชื่อหรอก
ดังนั้นในขณะที่สามารถทำได้อย่างแน่นอน (การโพสต์นี้ทำหน้าที่เป็นหลักฐานการมีอยู่ของความจริงที่ไม่อาจเพิกถอนได้) แต่นั่นไม่ได้หมายความว่า ควร จะเป็น
คุณต้องตัดสินใจด้วยตัวคุณเองไม่ว่าคุณจะทำหน้าที่เขียนจำนวนเท่าใดให้กับโปรแกรมแยกวิเคราะห์ HTML เพื่อวัตถุประสงค์พิเศษโดยเฉพาะ คนส่วนใหญ่ไม่ได้
แต่ฉันเป็น ☻
โซลูชันการแยกวิเคราะห์ HTML ตาม Regex ทั่วไป
ก่อนอื่นฉันจะแสดงให้เห็นว่าการแยกHTML โดยพลการด้วย regexes นั้นง่ายเพียงใด โปรแกรมเต็มในตอนท้ายของการโพสต์นี้ แต่หัวใจของโปรแกรมแยกวิเคราะห์คือ:
for (;;) {
given ($html) {
last when (pos || 0) >= length;
printf "\@%d=", (pos || 0);
print "doctype " when / \G (?&doctype) $RX_SUBS /xgc;
print "cdata " when / \G (?&cdata) $RX_SUBS /xgc;
print "xml " when / \G (?&xml) $RX_SUBS /xgc;
print "xhook " when / \G (?&xhook) $RX_SUBS /xgc;
print "script " when / \G (?&script) $RX_SUBS /xgc;
print "style " when / \G (?&style) $RX_SUBS /xgc;
print "comment " when / \G (?&comment) $RX_SUBS /xgc;
print "tag " when / \G (?&tag) $RX_SUBS /xgc;
print "untag " when / \G (?&untag) $RX_SUBS /xgc;
print "nasty " when / \G (?&nasty) $RX_SUBS /xgc;
print "text " when / \G (?&nontag) $RX_SUBS /xgc;
default {
die "UNCLASSIFIED: " .
substr($_, pos || 0, (length > 65) ? 65 : length);
}
}
}
ดูว่าอ่านง่ายแค่ไหน?
ตามที่เขียนไว้มันจะระบุแต่ละส่วนของ HTML และบอกตำแหน่งที่พบชิ้นส่วนนั้น คุณสามารถแก้ไขมันเพื่อทำสิ่งอื่นที่คุณต้องการได้อย่างง่ายดายด้วยชิ้นส่วนที่กำหนด
ฉันไม่มีกรณีทดสอบที่ล้มเหลว (ซ้าย :): ฉันได้รันโค้ดนี้สำเร็จแล้วกับไฟล์ HTML มากกว่า 100,000 ไฟล์ - ทุกๆอันที่ฉันสามารถทำได้อย่างรวดเร็วและง่ายดาย นอกเหนือจากนั้นฉันยังรันมันบนไฟล์ที่สร้างขึ้นเป็นพิเศษเพื่อแยก parsers ไร้เดียงสา
นี่ไม่ใช่ parser ไร้เดียงสา
โอ้ฉันแน่ใจว่ามันไม่สมบูรณ์แบบ แต่ฉันยังไม่สามารถทำลายมันได้ ฉันคิดว่าถึงแม้จะมีบางสิ่งบางอย่างการแก้ไขจะง่ายต่อการติดตั้งเนื่องจากโครงสร้างที่ชัดเจนของโปรแกรม แม้แต่โปรแกรม regex-heavy ก็ควรมีโครงสร้าง
ตอนนี้ไม่เป็นไรขอให้ฉันตอบคำถามของ OP
ตัวอย่างการแก้ไขงานของ OP โดยใช้ Regexes
html_input_rxโปรแกรมเล็ก ๆ ที่ฉันรวมไว้ด้านล่างสร้างผลลัพธ์ต่อไปนี้เพื่อให้คุณเห็นว่าการแยก HTML กับ regexes ทำงานได้ดีสำหรับสิ่งที่คุณต้องการทำ:
% html_input_rx Amazon.com-_Online_Shopping_for_Electronics,_Apparel,_Computers,_Books,_DVDs_\&_more.htm
input tag #1 at character 9955:
class => "searchSelect"
id => "twotabsearchtextbox"
name => "field-keywords"
size => "50"
style => "width:100%; background-color: #FFF;"
title => "Search for"
type => "text"
value => ""
input tag #2 at character 10335:
alt => "Go"
src => "http://g-ecx.images-amazon.com/images/G/01/x-locale/common/transparent-pixel._V192234675_.gif"
type => "image"
แท็กแยกวิเคราะห์ดูไม่มีอินพุตที่ชั่วร้าย
นี่คือแหล่งที่มาของโปรแกรมที่สร้างผลลัพธ์ด้านบน
#!/usr/bin/env perl
#
# html_input_rx - pull out all <input> tags from (X)HTML src
# via simple regex processing
#
# Tom Christiansen <tchrist@perl.com>
# Sat Nov 20 10:17:31 MST 2010
#
################################################################
use 5.012;
use strict;
use autodie;
use warnings FATAL => "all";
use subs qw{
see_no_evil
parse_input_tags
input descape dequote
load_patterns
};
use open ":std",
IN => ":bytes",
OUT => ":utf8";
use Encode qw< encode decode >;
###########################################################
parse_input_tags
see_no_evil
input
###########################################################
until eof(); sub parse_input_tags {
my $_ = shift();
our($Input_Tag_Rx, $Pull_Attr_Rx);
my $count = 0;
while (/$Input_Tag_Rx/pig) {
my $input_tag = $+{TAG};
my $place = pos() - length ${^MATCH};
printf "input tag #%d at character %d:\n", ++$count, $place;
my %attr = ();
while ($input_tag =~ /$Pull_Attr_Rx/g) {
my ($name, $value) = @+{ qw< NAME VALUE > };
$value = dequote($value);
if (exists $attr{$name}) {
printf "Discarding dup attr value '%s' on %s attr\n",
$attr{$name} // "<undef>", $name;
}
$attr{$name} = $value;
}
for my $name (sort keys %attr) {
printf " %10s => ", $name;
my $value = descape $attr{$name};
my @Q; given ($value) {
@Q = qw[ " " ] when !/'/ && !/"/;
@Q = qw[ " " ] when /'/ && !/"/;
@Q = qw[ ' ' ] when !/'/ && /"/;
@Q = qw[ q( ) ] when /'/ && /"/;
default { die "NOTREACHED" }
}
say $Q[0], $value, $Q[1];
}
print "\n";
}
}
sub dequote {
my $_ = $_[0];
s{
(?<quote> ["'] )
(?<BODY>
(?s: (?! \k<quote> ) . ) *
)
\k<quote>
}{$+{BODY}}six;
return $_;
}
sub descape {
my $string = $_[0];
for my $_ ($string) {
s{
(?<! % )
% ( \p{Hex_Digit} {2} )
}{
chr hex $1;
}gsex;
s{
& \043
( [0-9]+ )
(?: ;
| (?= [^0-9] )
)
}{
chr $1;
}gsex;
s{
& \043 x
( \p{ASCII_HexDigit} + )
(?: ;
| (?= \P{ASCII_HexDigit} )
)
}{
chr hex $1;
}gsex;
}
return $string;
}
sub input {
our ($RX_SUBS, $Meta_Tag_Rx);
my $_ = do { local $/; <> };
my $encoding = "iso-8859-1"; # web default; wish we had the HTTP headers :(
while (/$Meta_Tag_Rx/gi) {
my $meta = $+{META};
next unless $meta =~ m{ $RX_SUBS
(?= http-equiv )
(?&name)
(?&equals)
(?= (?"e)? content-type )
(?&value)
}six;
next unless $meta =~ m{ $RX_SUBS
(?= content ) (?&name)
(?&equals)
(?<CONTENT> (?&value) )
}six;
next unless $+{CONTENT} =~ m{ $RX_SUBS
(?= charset ) (?&name)
(?&equals)
(?<CHARSET> (?&value) )
}six;
if (lc $encoding ne lc $+{CHARSET}) {
say "[RESETTING ENCODING $encoding => $+{CHARSET}]";
$encoding = $+{CHARSET};
}
}
return decode($encoding, $_);
}
sub see_no_evil {
my $_ = shift();
s{ <! DOCTYPE .*? > }{}sx;
s{ <! \[ CDATA \[ .*? \]\] > }{}gsx;
s{ <script> .*? </script> }{}gsix;
s{ <!-- .*? --> }{}gsx;
return $_;
}
sub load_patterns {
our $RX_SUBS = qr{ (?(DEFINE)
(?<nv_pair> (?&name) (?&equals) (?&value) )
(?<name> \b (?= \pL ) [\w\-] + (?<= \pL ) \b )
(?<equals> (?&might_white) = (?&might_white) )
(?<value> (?"ed_value) | (?&unquoted_value) )
(?<unwhite_chunk> (?: (?! > ) \S ) + )
(?<unquoted_value> [\w\-] * )
(?<might_white> \s * )
(?<quoted_value>
(?<quote> ["'] )
(?: (?! \k<quote> ) . ) *
\k<quote>
)
(?<start_tag> < (?&might_white) )
(?<end_tag>
(?&might_white)
(?: (?&html_end_tag)
| (?&xhtml_end_tag)
)
)
(?<html_end_tag> > )
(?<xhtml_end_tag> / > )
) }six;
our $Meta_Tag_Rx = qr{ $RX_SUBS
(?<META>
(?&start_tag) meta \b
(?:
(?&might_white) (?&nv_pair)
) +
(?&end_tag)
)
}six;
our $Pull_Attr_Rx = qr{ $RX_SUBS
(?<NAME> (?&name) )
(?&equals)
(?<VALUE> (?&value) )
}six;
our $Input_Tag_Rx = qr{ $RX_SUBS
(?<TAG> (?&input_tag) )
(?(DEFINE)
(?<input_tag>
(?&start_tag)
input
(?&might_white)
(?&attributes)
(?&might_white)
(?&end_tag)
)
(?<attributes>
(?:
(?&might_white)
(?&one_attribute)
) *
)
(?<one_attribute>
\b
(?&legal_attribute)
(?&might_white) = (?&might_white)
(?:
(?"ed_value)
| (?&unquoted_value)
)
)
(?<legal_attribute>
(?: (?&optional_attribute)
| (?&standard_attribute)
| (?&event_attribute)
# for LEGAL parse only, comment out next line
| (?&illegal_attribute)
)
)
(?<illegal_attribute> (?&name) )
(?<required_attribute> (?#no required attributes) )
(?<optional_attribute>
(?&permitted_attribute)
| (?&deprecated_attribute)
)
# NB: The white space in string literals
# below DOES NOT COUNT! It's just
# there for legibility.
(?<permitted_attribute>
accept
| alt
| bottom
| check box
| checked
| disabled
| file
| hidden
| image
| max length
| middle
| name
| password
| radio
| read only
| reset
| right
| size
| src
| submit
| text
| top
| type
| value
)
(?<deprecated_attribute>
align
)
(?<standard_attribute>
access key
| class
| dir
| ltr
| id
| lang
| style
| tab index
| title
| xml:lang
)
(?<event_attribute>
on blur
| on change
| on click
| on dbl click
| on focus
| on mouse down
| on mouse move
| on mouse out
| on mouse over
| on mouse up
| on key down
| on key press
| on key up
| on select
)
)
}six;
}
UNITCHECK {
load_patterns();
}
END {
close(STDOUT)
|| die "can't close stdout: $!";
}
ไปแล้ว! ไม่มีอะไรให้มัน! :)
มีเพียงคุณเท่านั้นที่ จะตัดสินว่าทักษะของคุณกับ regexes นั้นขึ้นอยู่กับภารกิจในการวิเคราะห์ ระดับความสามารถของทุกคนแตกต่างกันและงานใหม่ทุกอย่างจะแตกต่างกัน สำหรับงานที่คุณมีชุดอินพุตที่กำหนดชัดเจน regexes เป็นตัวเลือกที่ถูกต้องเนื่องจากเป็นเรื่องไม่สำคัญที่จะนำมารวมกันเมื่อคุณมีชุดย่อยของ HTML ที่ จำกัด ในการจัดการ แม้แต่ผู้เริ่มต้น regex ควรจัดการงานเหล่านั้นด้วย regexes สิ่งอื่นใดที่เกินความจริง
อย่างไรก็ตามเมื่อ HTML เริ่มจับได้น้อยลงเมื่อเริ่มแตกในแบบที่คุณไม่สามารถคาดเดาได้ แต่มันถูกกฎหมายอย่างสมบูรณ์แบบเมื่อคุณต้องจับคู่สิ่งต่าง ๆ ที่แตกต่างกันหรือมีการพึ่งพาที่ซับซ้อนมากขึ้นในที่สุดคุณจะไปถึงจุดที่ คุณต้องทำงานให้หนักขึ้นเพื่อแก้ไขปัญหาที่ใช้ regexes มากกว่าที่คุณจะต้องใช้คลาสการแยกวิเคราะห์ ตำแหน่งที่จุดคุ้มทุนตกลงมาอีกครั้งในระดับความสะดวกสบายของคุณเองด้วย regexes
แล้วฉันควรทำอย่างไรดี?
ฉันไม่ได้จะบอกสิ่งที่คุณต้องทำหรือสิ่งที่คุณไม่สามารถทำ ฉันคิดว่ามันผิด ฉันแค่ต้องการนำเสนอคุณด้วยความเป็นไปได้เปิดตาของคุณเล็กน้อย คุณได้รับเลือกสิ่งที่คุณต้องการทำและวิธีที่คุณต้องการ ไม่มีข้อ จำกัด - และไม่มีใครรู้สถานการณ์ของตัวเองเช่นเดียวกับตัวคุณเอง หากสิ่งที่ดูเหมือนว่ามันทำงานมากเกินไปก็อาจจะเป็น การเขียนโปรแกรมควรสนุกคุณรู้ไหม หากไม่ใช่คุณอาจทำผิด
สามารถดูhtml_input_rxโปรแกรมของฉันได้หลายวิธี หนึ่งในนั้นคือคุณสามารถแยก HTML ด้วยนิพจน์ปกติได้ แต่อีกอย่างคือมันหนักกว่าและยากกว่าที่ใคร ๆ คิดว่ามาก สิ่งนี้สามารถนำไปสู่ข้อสรุปได้อย่างง่ายดายว่าโปรแกรมของฉันเป็นเครื่องพิสูจน์ถึงสิ่งที่คุณไม่ควรทำเพราะมันยากเกินไป
ฉันจะไม่เห็นด้วยกับสิ่งนั้น แน่นอนถ้าทุกอย่างที่ฉันทำในโปรแกรมของฉันไม่สมเหตุสมผลกับคุณหลังจากการศึกษาบางอย่างแล้วคุณไม่ควรพยายามใช้ regexes สำหรับงานประเภทนี้ สำหรับ HTML ที่เฉพาะเจาะจง regexes นั้นยอดเยี่ยม แต่สำหรับ HTML ทั่วไปพวกเขาจะเท่ากับความบ้าคลั่ง ฉันใช้การแยกวิเคราะห์คลาสตลอดเวลาโดยเฉพาะอย่างยิ่งถ้าเป็น HTML ฉันไม่ได้สร้างตัวเองขึ้นมา
Regexes ที่ดีที่สุดสำหรับปัญหาการแยกวิเคราะห์ HTML ขนาดเล็กซึ่งเป็นส่วนที่เล็กที่สุด
แม้ว่าโปรแกรมของฉันจะได้รับการอธิบายว่าทำไมคุณไม่ควรใช้ regexes สำหรับการแยกวิเคราะห์ HTML ทั่วไป - ซึ่งก็โอเคเพราะฉันคิดว่ามันควรจะเป็นแบบนั้น☺ - มันควรจะเป็นที่เปิดหูเปิดตา และน่ารังเกียจนิสัยที่น่ารังเกียจในการเขียนรูปแบบที่อ่านไม่ได้ไม่มีโครงสร้างและไม่สามารถทำลายได้
รูปแบบไม่จำเป็นต้องน่าเกลียดและพวกเขาไม่จำเป็นต้องยาก หากคุณสร้างรูปแบบที่น่าเกลียดมันเป็นภาพสะท้อนของคุณไม่ใช่พวกมัน
ภาษา Regex ที่งดงามอย่างมหัศจรรย์
ฉันได้รับการขอให้ชี้ให้เห็นว่าการแก้ปัญหาที่เป็นมืออาชีพของฉันได้ถูกเขียนเป็นภาษา Perl คุณประหลาดใจไหม? คุณไม่สังเกตเห็นไหม? การเปิดเผยนี้เป็นกระสุนหรือไม่?
มันเป็นความจริงที่ไม่ใช่เครื่องมือและภาษาการเขียนโปรแกรมอื่น ๆ ทั้งหมดนั้นค่อนข้างสะดวกสบายมีความหมายและมีประสิทธิภาพเมื่อพูดถึง regexes อย่างที่ Perl เป็น มีคลื่นความถี่ขนาดใหญ่ออกมีบางคนมีความเหมาะสมกว่าคนอื่น ๆ โดยทั่วไปภาษาที่แสดง regexes เป็นส่วนหนึ่งของภาษาหลักแทนที่จะเป็นห้องสมุดจะทำงานได้ง่ายขึ้น ฉันไม่ได้ทำอะไรกับ regexes ที่คุณทำไม่ได้พูด PCRE แม้ว่าคุณจะจัดโครงสร้างของโปรแกรมแตกต่างกันถ้าคุณใช้ C
ในที่สุดภาษาอื่น ๆ ก็จะติดต่อกับ Perl ตอนนี้ในแง่ของ regexes ฉันพูดแบบนี้เพราะเมื่อก่อน Perl เริ่มไม่มีใครมีอะไรเหมือน regexes ของ Perl พูดอะไรก็ได้ที่คุณชอบ แต่นี่คือที่ Perl ชัดเจนชนะ: ทุกคนคัดลอก regexes ของ Perl แม้ว่าจะอยู่ในขั้นตอนต่าง ๆ ของการพัฒนา Perl เป็นผู้บุกเบิกเกือบทุกอย่างที่คุณต้องพึ่งพาในรูปแบบที่ทันสมัยทุกวันนี้ไม่ว่าคุณจะใช้เครื่องมือหรือภาษาใดก็ตาม ดังนั้นในที่สุดคนอื่น ๆจะตามมาทัน
แต่พวกเขาจะตามไปยังจุดที่ Perl เคยเป็นอดีตในอดีตเหมือนตอนนี้ ทุกอย่างก้าวหน้า ใน regexes ถ้าไม่มีอะไรอื่นที่ Perl นำไปสู่คนอื่น ๆ ทำตาม Perl จะที่ไหนเมื่อคนอื่น ๆ จับกันได้ว่า Perl อยู่ที่ไหนในที่สุด? ฉันไม่มีความคิด แต่ฉันรู้ว่าเราก็ต้องประทับใจเช่นกัน เราน่าจะใกล้ชิดกับรูปแบบการประดิษฐ์ของPerl₆มากกว่า
หากคุณชอบสิ่งนั้น แต่ต้องการใช้ในPerl₅คุณอาจสนใจโมดูลRegexp :: Grammars ที่ยอดเยี่ยมของ Damian Conway มันยอดเยี่ยมมากและทำให้สิ่งที่ฉันทำที่นี่ในโปรแกรมของฉันดูเป็นเรื่องดั้งเดิมเหมือนกับที่ฉันสร้างรูปแบบที่ผู้คนอัดแน่นด้วยกันโดยไม่ต้องเว้นวรรคหรือตัวอักษร ลองดูสิ!
Simple HTML Chunker
นี่คือแหล่งที่มาที่สมบูรณ์ของตัวแยกวิเคราะห์ที่ฉันแสดงจุดศูนย์กลางจากจุดเริ่มต้นของการโพสต์นี้
ฉันไม่แนะนำให้คุณใช้สิ่งนี้กับคลาสการแยกวิเคราะห์ที่เข้มงวด แต่ฉันรู้สึกเบื่อหน่ายกับคนที่แกล้งทำเป็นว่าไม่มีใครสามารถแยก HTML ด้วย regexes เพียงเพราะพวกเขาทำไม่ได้ คุณสามารถทำได้อย่างชัดเจนและโปรแกรมนี้เป็นหลักฐานยืนยันว่า
แน่นอนว่ามันไม่ได้เป็นเรื่องง่าย แต่ก็เป็นไปได้!
และการพยายามทำเช่นนั้นเป็นการเสียเวลาอย่างมากเนื่องจากมีคลาสการแยกวิเคราะห์ที่ดีซึ่งคุณควรใช้สำหรับงานนี้ คำตอบที่ถูกต้องสำหรับผู้ที่พยายามแยกHTML โดยพลการนั้นไม่ได้เป็นไปไม่ได้ นั่นคือคำตอบที่ง่ายและไม่ตรงไปตรงมา คำตอบที่ถูกต้องและตรงไปตรงมาก็คือพวกเขาไม่ควรลองเพราะมันเป็นเรื่องที่น่ากังวลเกินกว่าที่จะคิดออกมาจากศูนย์ พวกเขาไม่ควรทำลายหลังที่พยายามดิ้นรนล้อที่ทำงานได้อย่างสมบูรณ์แบบ
ในทางกลับกัน HTML ที่อยู่ในชุดย่อยที่คาดเดาได้นั้นง่ายต่อการแยกวิเคราะห์ด้วย regexes ไม่น่าแปลกใจที่ผู้คนพยายามใช้มันเพราะสำหรับปัญหาเล็ก ๆ ปัญหาของเล่นอาจจะไม่มีอะไรง่ายไปกว่านี้อีกแล้ว นั่นเป็นสาเหตุที่สำคัญมากที่ต้องแยกความแตกต่างของสองงาน - เฉพาะเจาะจง vs ทั่วไป - เพราะสิ่งเหล่านี้ไม่จำเป็นต้องมีแนวทางเดียวกัน
ฉันหวังว่าในอนาคตที่นี่เพื่อดูคำถามเกี่ยวกับ HTML และ regexes ที่ยุติธรรมและซื่อสัตย์ยิ่งขึ้น
นี่คือ HTML lexer ของฉัน มันไม่ได้พยายามทำการแยกวิเคราะห์ที่ถูกต้อง มันแค่ระบุองค์ประกอบศัพท์ คุณอาจคิดว่ามันเป็นHTML chunkerมากกว่า parser HTML มันไม่ได้มีการให้อภัย HTML ที่เสียหายมากนักแม้ว่าจะมีค่าใช้จ่ายเล็กน้อยในทิศทางนั้น
แม้ว่าคุณจะไม่แยกวิเคราะห์ HTML แบบเต็ม ๆ ด้วยตัวเอง (และทำไมต้องเป็นคุณเป็นปัญหาที่แก้ไขได้!) โปรแกรมนี้มีบิต regex ที่น่าสนใจมากมายที่ฉันเชื่อว่าผู้คนจำนวนมากสามารถเรียนรู้ได้มากมาย สนุก!
#!/usr/bin/env perl
#
# chunk_HTML - a regex-based HTML chunker
#
# Tom Christiansen <tchrist@perl.com
# Sun Nov 21 19:16:02 MST 2010
########################################
use 5.012;
use strict;
use autodie;
use warnings qw< FATAL all >;
use open qw< IN :bytes OUT :utf8 :std >;
MAIN: {
$| = 1;
lex_html(my $page = slurpy());
exit();
}
########################################################################
sub lex_html {
our $RX_SUBS; ###############
my $html = shift(); # Am I... #
for (;;) { # forgiven? :)#
given ($html) { ###############
last when (pos || 0) >= length;
printf "\@%d=", (pos || 0);
print "doctype " when / \G (?&doctype) $RX_SUBS /xgc;
print "cdata " when / \G (?&cdata) $RX_SUBS /xgc;
print "xml " when / \G (?&xml) $RX_SUBS /xgc;
print "xhook " when / \G (?&xhook) $RX_SUBS /xgc;
print "script " when / \G (?&script) $RX_SUBS /xgc;
print "style " when / \G (?&style) $RX_SUBS /xgc;
print "comment " when / \G (?&comment) $RX_SUBS /xgc;
print "tag " when / \G (?&tag) $RX_SUBS /xgc;
print "untag " when / \G (?&untag) $RX_SUBS /xgc;
print "nasty " when / \G (?&nasty) $RX_SUBS /xgc;
print "text " when / \G (?&nontag) $RX_SUBS /xgc;
default {
die "UNCLASSIFIED: " .
substr($_, pos || 0, (length > 65) ? 65 : length);
}
}
}
say ".";
}
#####################
# Return correctly decoded contents of next complete
# file slurped in from the <ARGV> stream.
#
sub slurpy {
our ($RX_SUBS, $Meta_Tag_Rx);
my $_ = do { local $/; <ARGV> }; # read all input
return unless length;
use Encode qw< decode >;
my $bom = "";
given ($_) {
$bom = "UTF-32LE" when / ^ \xFf \xFe \0 \0 /x; # LE
$bom = "UTF-32BE" when / ^ \0 \0 \xFe \xFf /x; # BE
$bom = "UTF-16LE" when / ^ \xFf \xFe /x; # le
$bom = "UTF-16BE" when / ^ \xFe \xFf /x; # be
$bom = "UTF-8" when / ^ \xEF \xBB \xBF /x; # st00pid
}
if ($bom) {
say "[BOM $bom]";
s/^...// if $bom eq "UTF-8"; # st00pid
# Must use UTF-(16|32) w/o -[BL]E to strip BOM.
$bom =~ s/-[LB]E//;
return decode($bom, $_);
# if BOM found, don't fall through to look
# for embedded encoding spec
}
# Latin1 is web default if not otherwise specified.
# No way to do this correctly if it was overridden
# in the HTTP header, since we assume stream contains
# HTML only, not also the HTTP header.
my $encoding = "iso-8859-1";
while (/ (?&xml) $RX_SUBS /pgx) {
my $xml = ${^MATCH};
next unless $xml =~ m{ $RX_SUBS
(?= encoding ) (?&name)
(?&equals)
(?"e) ?
(?<ENCODING> (?&value) )
}sx;
if (lc $encoding ne lc $+{ENCODING}) {
say "[XML ENCODING $encoding => $+{ENCODING}]";
$encoding = $+{ENCODING};
}
}
while (/$Meta_Tag_Rx/gi) {
my $meta = $+{META};
next unless $meta =~ m{ $RX_SUBS
(?= http-equiv ) (?&name)
(?&equals)
(?= (?"e)? content-type )
(?&value)
}six;
next unless $meta =~ m{ $RX_SUBS
(?= content ) (?&name)
(?&equals)
(?<CONTENT> (?&value) )
}six;
next unless $+{CONTENT} =~ m{ $RX_SUBS
(?= charset ) (?&name)
(?&equals)
(?<CHARSET> (?&value) )
}six;
if (lc $encoding ne lc $+{CHARSET}) {
say "[HTTP-EQUIV ENCODING $encoding => $+{CHARSET}]";
$encoding = $+{CHARSET};
}
}
return decode($encoding, $_);
}
########################################################################
# Make sure to this function is called
# as soon as source unit has been compiled.
UNITCHECK { load_rxsubs() }
# useful regex subroutines for HTML parsing
sub load_rxsubs {
our $RX_SUBS = qr{
(?(DEFINE)
(?<WS> \s * )
(?<any_nv_pair> (?&name) (?&equals) (?&value) )
(?<name> \b (?= \pL ) [\w:\-] + \b )
(?<equals> (?&WS) = (?&WS) )
(?<value> (?"ed_value) | (?&unquoted_value) )
(?<unwhite_chunk> (?: (?! > ) \S ) + )
(?<unquoted_value> [\w:\-] * )
(?<any_quote> ["'] )
(?<quoted_value>
(?<quote> (?&any_quote) )
(?: (?! \k<quote> ) . ) *
\k<quote>
)
(?<start_tag> < (?&WS) )
(?<html_end_tag> > )
(?<xhtml_end_tag> / > )
(?<end_tag>
(?&WS)
(?: (?&html_end_tag)
| (?&xhtml_end_tag) )
)
(?<tag>
(?&start_tag)
(?&name)
(?:
(?&WS)
(?&any_nv_pair)
) *
(?&end_tag)
)
(?<untag> </ (?&name) > )
# starts like a tag, but has screwed up quotes inside it
(?<nasty>
(?&start_tag)
(?&name)
.*?
(?&end_tag)
)
(?<nontag> [^<] + )
(?<string> (?"ed_value) )
(?<word> (?&name) )
(?<doctype>
<!DOCTYPE
# please don't feed me nonHTML
### (?&WS) HTML
[^>]* >
)
(?<cdata> <!\[CDATA\[ .*? \]\] > )
(?<script> (?= <script ) (?&tag) .*? </script> )
(?<style> (?= <style ) (?&tag) .*? </style> )
(?<comment> <!-- .*? --> )
(?<xml>
< \? xml
(?:
(?&WS)
(?&any_nv_pair)
) *
(?&WS)
\? >
)
(?<xhook> < \? .*? \? > )
)
}six;
our $Meta_Tag_Rx = qr{ $RX_SUBS
(?<META>
(?&start_tag) meta \b
(?:
(?&WS) (?&any_nv_pair)
) +
(?&end_tag)
)
}six;
}
# nobody *ever* remembers to do this!
END { close STDOUT }