Check if page contains specific word - perl

How can I check if a page contains a specific word. Example: I want to return true or false if the page contains the word "candybar". Notice that the "candybar" could be in between tags (candybar) sometimes and sometimes not. How do I accomplish this?
Here is my code for "grabing" the site (just dont now how to check through the site):
#!/usr/bin/perl -w
use utf8;
use RPC::XML;
use RPC::XML::Client;
use Data::Dumper;
use Encode;
use Time::HiRes qw(usleep);
print "Content-type:text/html\n\n";
use LWP::Simple;
$pageURL = "http://example.com";
$simplePage=get($pageURL);
if ($simplePage =~ m/candybar/) {
print "its there!";
}

I'd suggest that you use some kind of parser, if you're looking for words in HTML or anything else that's tagged in a known way [XML, for example]. I use HTML::Tokeparser but there's many parsing modules on CPAN.
I've left the explanation of the returns from the parser as comments, in case you use this parser. This is extracted from a live program that I use to machine translate the text in web pages, so I've taken out some bits and pieces.
The comment above about checking status and content of returns from LWP, is very sensible too, if the website is off-line, you need to know that.
open( my $fh, "<:utf8", $file ) || die "Can't open $file : $!";
my $p = HTML::TokeParser->new($fh) || die "Can't open: $!";
$p->empty_element_tags(1); # configure its behaviour
# put output into here and it's cumulated
while ( my $token = $p->get_token ) {
#["S", $tag, $attr, $attrseq, $text]
#["E", $tag, $text]
#["T", $text, $is_data]
#["C", $text]
#["D", $text]
#["PI", $token0, $text
my ($type,$string) = get_output($token) ;
# ["T", $text, $is_data] : rule for text
if ( $type eq 'T' && $string =~ /^candybar/ ) {
}

Related

function call in perl

As a part of my course work I have been learning perl programming language for the first time in last the few weeks. I have been writing small functions and making function calls. I have written a function for string matching.
use strict;
use warnings;
sub find_multi_string {
my ($file, #strings) = #_;
my $fh;
open ($fh, "<$file");
#store the whole file in an array
my #array = <$fh>;
for my $string (#strings) {
if (grep /$string/, #array) {
next;
} else {
die "Cannot find $string in $file";
}
}
return 1;
}
find_multi_string('file name', 'string1','string2','string3','string4','string 5');
In the above script I'm passing the arguments in the function call. The script works.
But I'd like to know if there is way to specify the file name and string1... string n in an array in the program itself and just make the function call.
find_multi_string();
That would be a mistake, always pass parameters and return values to your subroutines.
What you're describing is essentially using subroutines solely to subdivide and document your code. If you were to do that, it would better to just remove the subroutine entirely and include a comment before the section of code.
Overall, your code looks good as is. You probably will want to use quotemeta though, and your logic can be simplified a little:
use strict;
use warnings;
use autodie;
sub find_multi_string {
my ($file, #strings) = #_;
# Load the file
my $data = do {
open my $fh, "<", $file;
local $/;
<$fh>
};
for my $string (#strings) {
if ($data !~ /\Q$string/) {
die "Cannot find $string in $file";
}
}
return 1;
}
find_multi_string('file name', 'string1','string2','string3','string4','string 5');
A few improvements of your original code:
use autodie
use 3-args open
as you want to check anywhere in the file, just load the file as a single string
if the matching string are just text without metacharacters from regexp, just use the index function
Your question is about passing the function arguments from your program.
I suspect that you are looking for #ARGV. See perlvar.
Here is the modified code:
use strict;
use warnings;
use autodie;
sub find_multi_string {
my ($file, #strings) = #_;
my $content = do {
open my $fh, '<', $file;
local $/;
<$fh>
};
foreach (#strings) {
die "Cannot find $string in $file" unless index($content, $_) >= 0;
}
return 1;
}
find_multi_string(#ARGV);

PERL CGI multiple content types. How To Download File AND view contents.

A page that prints out a file (on the server) contents and provides a direct download link.
Download File HERE
Start contents of file:
line 1
line 2
line 3
...
I am not sure of the best way and the right header that will allow a download link and HTML text. This prints out blank
print $mycgi->header(
-cookie => $mycookie,
-Type => "application/x-download"
-'Content-Disposition'=>'attachment; filename="FileName"'
);
You can include a link to a script and pass the filename as a parameter. The link might look something like this:
http://url/to/script?action=download&file=foo
Below that, simply print the contents of the file:
#!/usr/bin/perl -T
use strict;
use warnings;
use CGI qw/escapeHTML/;
my $q = CGI->new;
print $q->header,
$q->start_html('foo'),
$q->a({ -href => 'http://url/to/script?action=download&file=foo' }, 'Click to download'),
"<pre>";
open my $fh, "<", "/path/to/file" or die $!;
print escapeHTML($_) while <$fh>;
close $fh;
print "</pre>", $q->end_html;
Note that you should use escapeHTML() to prevent the browser from rendering anything in the file as HTML (which the <pre> tag alone does not take care of).
When the script is called with the action parameter set to download, use the application/x-download content type as you did above:
my $q = CGI->new;
# Untaint parameters
my ($action) = ($q->param('action') =~ /^(\w+)$/g);
my ($file) = ($q->param('file') =~ /^([-.\w]+)$/g);
# Map file parameter to the actual file name on your filesystem.
# The user should never know the actual file name. There are many
# ways you could implement this.
???
if ($action eq "download") {
print $q->header(
-type => "application/x-download",
-'Content-Disposition' => 'attachment; filename="FileName"'
);
open my $fh, "<", $file or die "Failed to open `$file' for reading: $!";
print while <$fh>;
close $fh;
}
Note that you also need to print the contents of the file in the body of the response.

Perl: Downloading all .jpgs from a web directory

#!/usr/bin/perl
use strict;
use warnings;
use WWW::Mechanize;
use FindBin qw($Bin);
print $Bin;
my $folder = "$Bin/Resources";
mkdir($folder, 0700) unless(-d $folder );
chdir($folder) or die "can't chdir $folder\n";
my $url = 'http://www.ukgamingcomputers.co.uk/images/zalmanz11plus.jpg';
my $local_file_name = 'pic.jpg';
my $mech = WWW::Mechanize->new;
$mech->get( $url, ":content_file" => $local_file_name );
I am currently using this code to download a .jpg and put it in a folder called Resources. I want to download all the .jpgs in the http://www.ukgamingcomputers.co.uk/images/ directory. I have absolutely no idea how I would achieve this. If you have a code solution, I would be grateful!
I'm afraid you can't do that. It is also unlikely that the web site owner would want you to.
There is no practical problem with downloading an image in that path, but to fetch them all you need to know what they are called, and there is no way to get a directory listing using HTTP.
You could crawl the site, fetch all the HTML pages from it, and find the names of all the image files those pages link to, but that would be awkward to do and even less likely to be acceptable to the site owner. It would also get you only the images used on the site, and not all the images in the directory.
Some HTTP servers are configured to return a listing of the directory in HTML if no specific file is specified in the URL and there is no default index.html file to send, but that is unusual nowadays as it represents a security breach.
If you think the site owner won't mind you helping yourself to his pictures, why not just send an email asking for a copy of them?
Sort of following your example, this pulls jpgs from that site you listed.
#!/usr/bin/perl
use strict;
use warnings;
use WWW::Mechanize;
use WWW::Mechanize::Link;
use Getopt::Long;
exit int main( parse_args() );
sub main {
my $opts = shift;
my $folder = $opts->{folder};
chdir($folder) or die "can't chdir $opts->{folder}\n";
my $mech = WWW::Mechanize->new;
$mech->get( $opts->{url} );
for my $link ( $mech->links() ) {
next unless $link->text() =~ /jpg$/;
$mech->get( $link->url() );
$mech->save_content( $link->text() );
}
}
sub parse_args {
my %opts = (
url => "http://www.ukgamingcomputers.co.uk/images/",
folder => "/home/kprice/tmp",
);
GetOptions( \%opts, 'url|u=s', 'folder|d=s', ) or die $!;
return \%opts;
}
If you're on linux, this would work, but pull everything from that link:
$ wget -r http://www.ukgamingcomputers.co.uk/images/
EDIT: I corrected it a little after that quick copy/paste.
Do you have to use WWW::Mechanize?
Here's an example with HTML::LinkExtor and LWP::Simple
EDIT: This actually pulls all images from given address.
#!/usr/bin/perl
use warnings;
use strict;
use LWP::Simple;
use HTML::LinkExtor;
use Data::Dumper;
$Data::Dumper::Indent=1;
die "usage: $0 url\n" if #ARGV != 1;
my $url = shift;
$|++;
if ( $url !~ /^http/ ) {
print "usage: url ( http(s)://www.example.com/ )\n";
exit(1);
}
my %images = ();
my $html = get($url)
or die "could not get $url\n";
my $parser = HTML::LinkExtor->new(undef, $url);
$parser->parse($html);
my #all_link_refs = $parser->links();
for my $link_ref ( #all_link_refs ) {
my ( $html_tag, $attr_name, $this_url ) = #$link_ref;
if ( ($html_tag eq 'img') ) {
my $image_name = (split("/", $this_url))[-1];
$images{$image_name}++;
if ( $images{$image_name} == 1 ) {
print "Downloading $this_url to $image_name...\n";
open my $PIC, ">", "$image_name";
my $image = get($this_url);
print $PIC $image;
}
}
}
OUPUT:
$ test.pl http://google.com
Downloading http://google.com/intl/en_ALL/images/srpr/logo1w.png to logo1w.png...

using Perl to scrape a website

I am interested in writing a perl script that goes to the following link and extracts the number 1975: https://familysearch.org/search/collection/results#count=20&query=%2Bevent_place_level_1%3ACalifornia%20%2Bevent_place_level_2%3A%22San%20Diego%22%20%2Bbirth_year%3A1923-1923~%20%2Bgender%3AM%20%2Brace%3AWhite&collection_id=2000219
That website is the amount of white men born in the year 1923 who live in San Diego County, California in 1940. I am trying to do this in a loop structure to generalize over multiple counties and birth years.
In the file, locations.txt, I put the list of counties, such as San Diego County.
The current code runs, but instead of the # 1975, it displays unknown. The number 1975 should be in $val\n.
I would very much appreciate any help!
#!/usr/bin/perl
use strict;
use LWP::Simple;
open(L, "locations26.txt");
my $url = 'https://familysearch.org/search/collection/results#count=20&query=%2Bevent_place_level_1%3A%22California%22%20%2Bevent_place_level_2%3A%22%LOCATION%%22%20%2Bbirth_year%3A%YEAR%-%YEAR%~%20%2Bgender%3AM%20%2Brace%3AWhite&collection_id=2000219';
open(O, ">out26.txt");
my $oldh = select(O);
$| = 1;
select($oldh);
while (my $location = <L>) {
chomp($location);
$location =~ s/ /+/g;
foreach my $year (1923..1923) {
my $u = $url;
$u =~ s/%LOCATION%/$location/;
$u =~ s/%YEAR%/$year/;
#print "$u\n";
my $content = get($u);
my $val = 'unknown';
if ($content =~ / of .strong.([0-9,]+)..strong. /) {
$val = $1;
}
$val =~ s/,//g;
$location =~ s/\+/ /g;
print "'$location',$year,$val\n";
print O "'$location',$year,$val\n";
}
}
Update: API is not a viable solution. I have been in contact with the site developer. The API does not apply to that part of the webpage. Hence, any solution pertaining to JSON will not be applicbale.
It would appear that your data is generated by Javascript and thus LWP cannot help you. That said, it seems that the site you are interested in has a developer API: https://familysearch.org/developers/
I recommend using Mojo::URL to construct your query and either Mojo::DOM or Mojo::JSON to parse XML or JSON results respectively. Of course other modules will work too, but these tools are very nicely integrated and let you get started quickly.
You could use WWW::Mechanize::Firefox to process any site that could be loaded by Firefox.
http://metacpan.org/pod/WWW::Mechanize::Firefox::Examples
You have to install the Mozrepl plugin and you will be able to process the web page contant via this module. Basically you will "remotly control" the browser.
Here is an example (maybe working)
use strict;
use warnings;
use WWW::Mechanize::Firefox;
my $mech = WWW::Mechanize::Firefox->new(
activate => 1, # bring the tab to the foreground
);
$mech->get('https://familysearch.org/search/collection/results#count=20&query=%2Bevent_place_level_1%3ACalifornia%20%2Bevent_place_level_2%3A%22San%20Diego%22%20%2Bbirth_year%3A1923-1923~%20%2Bgender%3AM%20%2Brace%3AWhite&collection_id=2000219',':content_file' => 'main.html');
my $retries = 10;
while ($retries-- and ! $mech->is_visible( xpath => '//*[#class="form-submit"]' )) {
print "Sleep until we find the thing\n";
sleep 2;
};
die "Timeout" if 0 > $retries;
#fill out the search form
my #forms = $mech->forms();
#<input id="census_bp" name="birth_place" type="text" tabindex="0"/>
#A selector prefixed with '#' must match the id attribute of the input. A selector prefixed with '.' matches the class attribute. A selector prefixed with '^' or with no prefix matches the name attribute.
$mech->field( birth_place => 'value_for_birth_place' );
# Click on the submit
$mech->click({xpath => '//*[#class="form-submit"]'});
If you use your browser's development tools, you can clearly see the JSON request that the page you link to uses to get the data you're looking for.
This program should do what you want. I've added a bunch of comments for readability and explanation, as well as made a few other changes.
use warnings;
use strict;
use LWP::UserAgent;
use JSON;
use CGI qw/escape/;
# Create an LWP User-Agent object for sending HTTP requests.
my $ua = LWP::UserAgent->new;
# Open data files
open(L, 'locations26.txt') or die "Can't open locations: $!";
open(O, '>', 'out26.txt') or die "Can't open output file: $!";
# Enable autoflush on the output file handle
my $oldh = select(O);
$| = 1;
select($oldh);
while (my $location = <L>) {
# This regular expression is like chomp, but removes both Windows and
# *nix line-endings, regardless of the system the script is running on.
$location =~ s/[\r\n]//g;
foreach my $year (1923..1923) {
# If you need to add quotes around the location, use "\"$location\"".
my %args = (LOCATION => $location, YEAR => $year);
my $url = 'https://familysearch.org/proxy?uri=https%3A%2F%2Ffamilysearch.org%2Fsearch%2Frecords%3Fcount%3D20%26query%3D%252Bevent_place_level_1%253ACalifornia%2520%252Bevent_place_level_2%253A^LOCATION^%2520%252Bbirth_year%253A^YEAR^-^YEAR^~%2520%252Bgender%253AM%2520%252Brace%253AWhite%26collection_id%3D2000219';
# Note that values need to be doubly-escaped because of the
# weird way their website is set up (the "/proxy" URL we're
# requesting is subsequently loading some *other* URL which
# is provided to "/proxy" as a URL-encoded URL).
#
# This regular expression replaces any ^WHATEVER^ in the URL
# with the double-URL-encoded value of WHATEVER in %args.
# The /e flag causes the replacement to be evaluated as Perl
# code. This way I can look data up in a hash and do URL-encoding
# as part of the regular expression without an extra step.
$url =~ s/\^([A-Z]+)\^/escape(escape($args{$1}))/ge;
#print "$url\n";
# Create an HTTP request object for this URL.
my $request = HTTP::Request->new(GET => $url);
# This HTTP header is required. The server outputs garbage if
# it's not present.
$request->push_header('Content-Type' => 'application/json');
# Send the request and check for an error from the server.
my $response = $ua->request($request);
die "Error ".$response->code if !$response->is_success;
# The response should be JSON.
my $obj = from_json($response->content);
my $str = "$args{LOCATION},$args{YEAR},$obj->{totalHits}\n";
print O $str;
print $str;
}
}
What about this simple script without firefox ? I had investigated the site a bit to understand how it works, and I saw some JSON requests with firebug firefox addon, so I know which URL to query to get the relevant stuff. Here is the code :
use strict; use warnings;
use JSON::XS;
use LWP::UserAgent;
use HTTP::Request;
my $ua = LWP::UserAgent->new();
open my $fh, '<', 'locations2.txt' or die $!;
open my $fh2, '>>', 'out2.txt' or die $!;
# iterate over locations from locations2.txt file
while (my $place = <$fh>) {
# remove line ending
chomp $place;
# iterate over years
foreach my $year (1923..1925) {
# building URL with the variables
my $url = "https://familysearch.org/proxy?uri=https%3A%2F%2Ffamilysearch.org%2Fsearch%2Frecords%3Fcount%3D20%26query%3D%252Bevent_place_level_1%253ACalifornia%2520%252Bevent_place_level_2%253A%2522$place%2522%2520%252Bbirth_year%253A$year-$year~%2520%252Bgender%253AM%2520%252Brace%253AWhite%26collection_id%3D2000219";
my $request = HTTP::Request->new(GET => $url);
# faking referer (where we comes from)
$request->header('Referer', 'https://familysearch.org/search/collection/results');
# setting expected format header for response as JSON
$request->header('content_type', 'application/json');
my $response = $ua->request($request);
if ($response->code == 200) {
# this line convert a JSON to Perl HASH
my $hash = decode_json $response->content;
my $val = $hash->{totalHits};
print $fh2 "year $year, place $place : $val\n";
}
else {
die $response->status_line;
}
}
}
END{ close $fh; close $fh2; }
This seems to do what you need. Instead of waiting for the disappearance of the hourglass it waits - more obviously I think - for the appearance of the text node you're interested in.
use 5.010;
use warnings;
use WWW::Mechanize::Firefox;
STDOUT->autoflush;
my $url = 'https://familysearch.org/search/collection/results#count=20&query=%2Bevent_place_level_1%3ACalifornia%20%2Bevent_place_level_2%3A%22San%20Diego%22%20%2Bbirth_year%3A1923-1923~%20%2Bgender%3AM%20%2Brace%3AWhite&collection_id=2000219';
my $mech = WWW::Mechanize::Firefox->new(tab => qr/FamilySearch\.org/, create => 1, activate => 1);
$mech->autoclose_tab(0);
$mech->get('about:blank');
$mech->get($url);
my $text;
while () {
sleep 1;
$text = $mech->xpath('//p[#class="num-search-results"]/text()', maybe => 1);
last if defined $text;
}
my $results = $text->{nodeValue};
say $results;
if ($results =~ /([\d,]+)\s+results/) {
(my $n = $1) =~ tr/,//d;
say $n;
}
output
1-20 of 1,975 results
1975
Update
This update is with special thanks to #nandhp, who inspired me to look at the underlying data server that produces the data in JSON format.
Rather than making a request via the superfluous https://familysearch.org/proxy this code accesses the server directly at https://familysearch.org/search/records, reencodes the JSON and dumps the required data out of the resulting structure. This has the advantage of both speed (the requests are served about once a second - more than ten times faster than with the equivalent request from the basic web site) and stability (as you note, the site is very flaky - in contrast I have never seen an error using this method).
use strict;
use warnings;
use LWP::UserAgent;
use URI;
use JSON;
use autodie;
STDOUT->autoflush;
open my $fh, '<', 'locations26.txt';
my #locations = <$fh>;
chomp #locations;
open my $outfh, '>', 'out26.txt';
my $ua = LWP::UserAgent->new;
for my $county (#locations[36, 0..2]) {
for my $year (1923 .. 1926) {
my $total = familysearch_info($county, $year);
print STDOUT "$county,$year,$total\n";
print $outfh "$county,$year,$total\n";
}
print "\n";
}
sub familysearch_info {
my ($county, $year) = #_;
my $query = join ' ', (
'+event_place_level_1:California',
sprintf('+event_place_level_2:"%s"', $county),
sprintf('+birth_year:%1$d-%1$d~', $year),
'+gender:M',
'+race:White',
);
my $url = URI->new('https://familysearch.org/search/records');
$url->query_form(
collection_id => 2000219,
count => 20,
query => $query);
my $resp = $ua->get($url, 'Content-Type'=> 'application/json');
my $data = decode_json($resp->decoded_content);
return $data->{totalHits};
}
output
San Diego,1923,1975
San Diego,1924,2004
San Diego,1925,1871
San Diego,1926,1908
Alameda,1923,3577
Alameda,1924,3617
Alameda,1925,3567
Alameda,1926,3464
Alpine,1923,1
Alpine,1924,2
Alpine,1925,0
Alpine,1926,1
Amador,1923,222
Amador,1924,248
Amador,1925,134
Amador,1926,67
I do not know how to post revised code from the solution above.
This code does not (yet) compile correctly. However, I have made some essential update to definitely head in that direction.
I would very much appreciate help on this updated code. I do not know how to post this code and this follow up such that it appease the lords who run this sight.
It get stuck at the sleep line. Any advice on how to proceed past it would be much appreciated!
use strict;
use warnings;
use WWW::Mechanize::Firefox;
my $mech = WWW::Mechanize::Firefox->new(
activate => 1, # bring the tab to the foreground
);
$mech->get('https://familysearch.org/search/collection/results#count=20&query=%2Bevent_place_level_1%3ACalifornia%20%2Bevent_place_level_2%3A%22San%20Diego%22%20%2Bbirth_year%3A1923-1923~%20%2Bgender%3AM%20%2Brace%3AWhite&collection_id=2000219',':content_file' => 'main.html', synchronize => 0);
my $retries = 10;
while ($retries-- and $mech->is_visible( xpath => '//*[#id="hourglass"]' )) {
print "Sleep until we find the thing\n";
sleep 2;
};
die "Timeout while waiting for application" if 0 > $retries;
# Now the hourglass is not visible anymore
#fill out the search form
my #forms = $mech->forms();
#<input id="census_bp" name="birth_place" type="text" tabindex="0"/>
#A selector prefixed with '#' must match the id attribute of the input. A selector prefixed with '.' matches the class attribute. A selector prefixed with '^' or with no prefix matches the name attribute.
$mech->field( birth_place => 'value_for_birth_place' );
# Click on the submit
$mech->click({xpath => '//*[#class="form-submit"]'});
You should set the current form before accessing a field:
"Given the name of a field, set its value to the value specified. This applies to the current form (as set by the "form_name()" or "form_number()" method or defaulting to the first form on the page)."
$mech->form_name( 'census-search' );
$mech->field( birth_place => 'value_for_birth_place' );
Sorry, I am not able too try this code out and thanks for open a question for a new question.

How to search a string in web page and print that full line in which search string is present?

I'm new to programming, learning perl as well.
Here's my question: How do I search a string in web page and print that full line in which search string is present?
Is it possible to find/hit directly that string and then print that full line in which search string is present? Do we need to use xpaths compulsory for this?
If it is just a very basic string you are looking for you can use LWP::Simple and a small regular expression like this:
use LWP::Simple;
my $doc = get('http://stackoverflow.com/q/11771655/479133') || die "GET failed";
foreach my $line (split("\n", $doc)) {
print $line and last if $line =~ m/Here's my query/;
}
There are countless modules available on CPAN to do such things. Have a look at Task::Kensho::WebCrawling if you need something "bigger".
LWP::UserAgent and HTML::Parser can be used:
#!/usr/bin/env perl
use strict;
use warnings;
use HTML::Parser;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
my $response = $ua->get('http://search.cpan.org/');
if ( !$response->is_success ) {
print "No matches\n";
exit 1;
}
my $parser = HTML::Parser->new( 'text_h' => [ \&text_handler, 'dtext' ] );
$parser->parse( $response->decoded_content );
sub text_handler {
chomp( my $text = shift );
if ( $text =~ /language/i ) {
print "Matched: $text\n";
}
}