[%
my $html= '';
my @errors;
my @types= q(
Wi perlquestion SoPW Seekers of Perl Wisdom
D monkdiscuss PMD PM Discussions
Ob obfuscated Obfu Obfuscation
CU CUFP CUFP Cool Uses For Perl
CC sourcecode Code Code Catacombs
CQ categorized_question CatQ Categorized Questions
CA categorized_answer CatA Categorized Answers
Hlp sitefaqlet Help Monk Help
Tu perltutorial Tut Tutorial
U user User
Po poem Poem
Cr perlcraft Craft
Sn snippet Snippet
N perlnews News
Q quest Quest
Pol poll Poll
M perlmeditation Med Meditations
SP scratchpad SPad Scratch Pad
MR modulereview ModRev Module Review
BR bookreview BkRev Book Review
pPd perlman perlman Perl Manpage
pFn perlfunc perlfunc Perl Function
pFq perlfaq_nodetype perlfaq Perl FAQ
) =~ /(\S.*\S)/g;
my( %abbr, %desc, %typeId, %link );
for( @types ) {
my( $abbr, $type, $link, $desc )= split " ", $_, 4;
$type =~ tr/_/ /;
my $id= getId( getType($type) );
$typeId{$type}= $id;
$abbr{$type}= $abbr;
$desc{$type}= $desc || $link;
$link{ $id }= $link;
$_= $type;
}
my %typeTable= qw(
snippet snippet
bookreview review
modulereview review
sourcecode sourcecode
poll polls
);
my %fieldOfTable= (
snippet => [qw( snippetdesc snippetcode )],
review => [qw( itemdescription usercomment doctext )],
sourcecode => [qw( codedescription doctext )],
polls => ['choices'],
#user => [qw( scratchpad )], # Needs to change
);
my @sects;
my $sects= do {
my $negSects= ( $q->param("xs") )[-1] ? 1 : 0;
my %checked;
@checked{keys %abbr}= map {
( ()= $q->param($abbr{$_}) ) ? 1 : 0;
} keys %abbr;
@sects= grep $negSects != $checked{$_}, keys %abbr;
@sects= @types if ! @sects;
join ", ", map $typeId{$_}, @sects;
};
my @criteria;
my @users= grep length, $q->param("a");
if( 1 == @users && $users[0] =~ m#^(\s*\[[^\]]+\])+\s*$#g ) {
@users= $users[0] =~ m#\[([^\]]+)\]#g;
}
for my $user ( @users ) {
my $type = "user";
my $reason = "does not exist";
my $U;
if( $user !~ m#^id://(\d+)$# ) {
$U = getNode( $user, "user" );
} else {
( $type, $user ) = ( "node ID", $1 );
$U = getNodeById( $user );
if( $U && "user" ne $U->{type}{title} ) {
undef $U;
$reason = "is not a user";
}
}
if( $U ) {
$user= getId($U);
} else {
$user= 0;
push @errors, qq[\u$type "] . $query->escapeHTML($user)
. qq[" $reason.
];
}
}
@users= grep $_, @users;
my $negAuthor= ( $q->param("xa") )[-1] ? 1 : 0;
$negAuthor= $negAuthor ? " NOT" : "";
if( @users ) {
push @criteria, "n.author_user$negAuthor IN ( "
. join( ", ", @users ) . " )";
}
my $replies= ( $q->param("re") )[-1];
$q->param( "re", $replies );
my $xRoots= ()= $q->param("xr");
my $note= getId( getType("note") );
push @criteria, do {
if( "N" eq $replies ) { # No replies:
push @errors,
"No root nodes and no replies means no search.
"
if $xRoots;
$xRoots
? "n.node_id = 0" # Find nothing!
: "n.type_nodetype IN ( $sects )"; # Just sel. roots
} elsif( "A" eq $replies # All replies (same as
|| @sects == @types ) { # re.s from all sect.s):
$xRoots
? "n.type_nodetype = $note" #Just all re.s
: "n.type_nodetype IN ( $note, $sects )";#^ + sel. roots
} else { # Replies from sel. sects:
$q->param( "re", undef );
my $c= "( n.type_nodetype = $note"
. " AND root.type_nodetype IN ( $sects ) )";
$xRoots
? $c # Sel. re.s
: "( n.type_nodetype IN ( $sects ) OR $c )"; # ^ + roots
}
};
# ( Head Body ) + ( Includes Excludes ) + ( Terms Seperator )
my $getTerms= sub {
my( $textParam, $sepParam )= @_;
my $str= $q->param( $textParam );
my $sep= $q->param( $sepParam );
$sep =~ s/^\s*//;
$sep =~ s/\s*$//;
$sep= " " if ! length $sep;
$q->param( $sepParam, $sep );
my @terms= grep length, split /\Q$sep/, $str;
$q->param( $textParam, join $sep, @terms );
return @terms;
};
my @headHas= $getTerms->( "HIT", "HIS" );
my @headLacks= $getTerms->( "HET", "HES" );
my @bodyHas= $getTerms->( "BIT", "BIS" );
my @bodyLacks= $getTerms->( "BET", "BES" );
my( @tables, @fields );
push @tables, 'note',
"left join node as root on root.node_id=root_node";
if( @bodyHas || @bodyLacks ) {
my( %tables, %fields );
push @sects, 'note'
unless 'N' eq $replies;
for my $type ( @sects ) {
if( $typeTable{$type} ) {
++$tables{ $typeTable{$type} };
++$fields{$_}
for @{ $fieldOfTable{ $typeTable{$type} } };
} else {
++$tables{document};
++$fields{doctext};
}
}
push @tables, keys %tables;
push @fields, keys %fields;
}
my $tables= "node as n";
for my $table ( @tables ) {
if( $table =~ / / ) {
$tables .= "\n$table";
} else {
$tables .= "\nleft join $table on ${table}_id=n.node_id";
}
}
if( @headHas ) {
push @criteria, map {
my $quoted= $_;
$quoted =~ s#\\#\\\\#g; # MySQL bug
$quoted =~ s#(['%_\\\[\]])#\\$1#g;
"n.title LIKE '%$quoted%'";
} @headHas;
}
if( @headLacks ) {
push @criteria, map {
my $quoted= $_;
$quoted =~ s#\\#\\\\#g; # MySQL bug
$quoted =~ s#(['%_\\\[\]])#\\$1#g;
"n.title NOT LIKE '%$quoted%'";
} @headLacks;
}
if( @bodyHas ) {
push @criteria, map {
my $quoted= $_;
$quoted =~ s#\\#\\\\#g; # MySQL bug
$quoted =~ s#(['%_\\\[\]])#\\$1#g;
"( " . join( " OR ", map {
"$_ LIKE '%$quoted%'";
} @fields ) . " )";
} @bodyHas;
}
if( @bodyLacks ) {
push @criteria, map {
my $quoted= $_;
$quoted =~ s#\\#\\\\#g; # MySQL bug
$quoted =~ s#(['%_\\\[\]])#\\$1#g;
map {
"$_ NOT LIKE '%$quoted%'";
} @fields;
} @bodyLacks;
}
my $oldFirst= ! ( $q->param("nf") )[-1];
my $n0= $q->param("n0");
my $doSearch= $n0 && ! @errors;
my $lastNode= $DB->sqlSelect( "max(node_id)", "node" );
$n0 ||= $oldFirst ? 1 : $DB->sqlSelect( "max(node_id)", "node" );
push @criteria, "n.node_id BETWEEN !TBD!";
my $limit= 50;
if( $doSearch ) {
require Time::HiRes;
my @matches;
my $start= $n0;
my $startTime= Time::HiRes::time();
while( 1 ) {
my( $min, $max );
if( $oldFirst ) {
( $min, $max )= ( $n0, $n0+10000 );
$max= 1000 * int( $max/1000 + 0.5 );
$max= $lastNode if $lastNode < $max;
} else {
( $min, $max )= ( $n0-10000, $n0 );
$min= 1000 * int( $min/1000 + 0.5 );
$min= 1 if $min < 1;
}
$criteria[-1]= "n.node_id BETWEEN $min AND $max";
my $explainTime= Time::HiRes::time();
my $query= qq[
SELECT n.node_id, n.title, n.type_nodetype,
n.author_user, n.createtime, root.type_nodetype
FROM $tables
WHERE ] . join( " AND ", @criteria ) . qq[
ORDER BY n.node_id
LIMIT ] . ( $limit - @matches );
my $explain= $DB->getDatabaseHandle()->prepare(
"EXPLAIN $query" );
$explain->execute();
my $rec= $explain->fetchrow_hashref();
$explain->finish();
my $key_used= $rec->{key};
my $key_rows= $rec->{rows};
my $comment= $rec->{Comment};
$explainTime= Time::HiRes::time() - $explainTime;
if( 3 < $explainTime ) {
push @errors, ( $start==$n0 ? "Q" : "Remainder of q" )
. qq[uery was not run; Server is too busy ]
. sprintf(
qq[("explain" took %.2f seconds)
],
$explainTime
);
last;
}
unless( "PRIMARY" eq $key_used
or "" ne $key_used && $key_rows < 10000
) {
push @errors, ( $start==$n0 ? "Q" : "Remainder of q" )
. "uery would not run quickly"
. ( $comment ? " ($comment)" : "" )
. ".
\n";
last;
}
my $cursor= $DB->sqlSelectMany(
"n.node_id as node_id, n.title as title,
n.type_nodetype as type_nodetype,
n.author_user as author_user, n.createtime as createtime,
root.type_nodetype as root_nodetype",
$tables,
join( " AND ", @criteria ),
"ORDER BY n.node_id LIMIT " . ( $limit - @matches ),
);
my $rec;
while( $rec= $cursor->fetchrow_hashref() ) {
push @matches, $rec;
}
$cursor->finish();
if( @matches < $limit ) {
$n0= 1 + $max;
} else {
$n0= 1 + $matches[-1]{node_id};
last;
}
last if $lastNode < $n0;
my $runTime= Time::HiRes::time() - $startTime;
if( 10 < $runTime ) {
push @errors, ( $start==$n0 ? "Q" : "Remainder of q" )
. qq[uery was not run ]
. sprintf(
qq[(used %.2f seconds so far)
],
$runTime
);
last;
}
}
my $startDate= ( split " ", $DB->sqlSelect(
"createtime","node","node_id=$start") )[0];
my $endDate= ( split " ", $DB->sqlSelect(
"createtime","node","node_id=".($n0-1)) )[0];
my $matches= @matches;
$html .= qq[
Press a "Search" button (below) to continue (IDs $min thru $max).
\n]; } $html .= "' . linkNode( $NODE, "Reset search form" ) . "
\n"; $html .= $/ . htmlcode('openform') . $/; $html .= qq[
Match text containing ] . $q->textfield( "BIT", "", 60 )
. qq[
(seperate strings with ]
. $q->textfield( "BIS", " ", 2 ) . qq[ -- default is spaces)
] . $q->radio_group( "BH", [ "0", "1" ], "1", 0,
{ 0=>"Don't match -or-", 1=>"Also match" },
) . qq[ titles against above.
Match titles containing ]
. $q->textfield( "HIT", "", 60 )
. qq[
(separate strings with ]
. $q->textfield( "HIS", " ", 2 )
. qq[ -- default is spaces)
] . $q->radio_group(
"xa", [ "0", "1" ], "0", 0, { 0=>"Match -or-", 1=>"Exclude" },
) . qq[ authors ] . $q->textfield( "a", "", 20 )
. qq[
(use "[one] [two]" to list multiple authors)
(Searching by author doesn't work for Categorized
Questions and Answers yet.)
Search ] . $q->radio_group(
-name=>"nf", -values=>[ "1", "0" ], -default=>"0",
-labels=>{ 1=>"Newest first -or-", 0=>"Oldest first" },
-disabled=>"disabled",
) . qq[,
starting at node
] . $q->textfield( "n0", "0", 12 ) . qq[ (]
. ( split " ", $DB->sqlSelect(
"createtime","node","node_id=$n0") )[0]
. qq[).
Search ] . $q->radio_group(
"xs", [0,1], 0, 0, {0=>"only -or-",1=>"all but"},
) . qq[
the following sections:];
$html .= qq[
Skip text containing ]
. $q->textfield( "BET", "", 60 )
. qq[
(seperate strings with ]
. $q->textfield( "BES", " ", 2 )
. qq[ -- default is spaces)
(Does not exclude based on titles)
Skip titles containing ]
. $q->textfield( "HET", "", 60 )
. qq[
(seperate strings with ]
. $q->textfield( "HES", " ", 2 )
. qq[ -- default is spaces)
\n] . $q->radio_group( "xr", ["0","1"], "0", 1, { 0 => "Include root nodes from selected sections", 1 => "Don't include root nodes", }, ); $html .= qq[
\n] . $q->radio_group( "re", [qw( A S N )], "S", 1, { A => "Include replies from any section", S => "Include replies from selected sections", N => "Don't include replies", }, ); $html .= qq[\n
] . $q->submit("","Search") . qq[ Please be patient after submitting your search.
\n]; $html .= qq[\n]; $html .= qq[\n\n]; return "@errors$html"; %]