#!/usr/bin/perl
use strict;
use warnings;
use CGI;
use LWP::UserAgent;
my $ua = new LWP::UserAgent;
my $cgi = new CGI;
print $cgi->header, $cgi->start_html('XFN Proof of Concept'),
$cgi->h1('XFN Proof of Concept (Serverless Crawler)'),
$cgi->h3('See idea for concept'),
$cgi->hr, $cgi->start_form, $cgi->p('Enter a URL',$cgi->textfield('u')),
$cgi->submit, $cgi->end_form, $cgi->hr;
my $url;
if ($cgi->param('u')){
$url = $cgi->param('u');
$url='http://'.$url unless $url =~ /^http:\/\//;
}
print $cgi->h2("XFN for $url (Direct Link)") if $url;
my $content = $ua->get($url)->content;
#print $content;
#foreach my $link (//$content) {
#while ($content) {
#print $content;
my @links = get_links($content);
my %rel = get_rel(@links);
my @keys = keys %rel;
#foreach my $key (@keys) {
# print "$key: ",@{ $rel{$key} },"\n";
#}
my %xfn = get_xfn(%rel);
#print %rel;
@keys = keys %xfn;
foreach my $key ( @keys ) {
if ( ${ $xfn{$key} }[0]) {
print $cgi->p("$key (Site): "),
$cgi->p("@{ $xfn{$key} }"),"\n";
}
}
print $cgi->end_html;
sub get_links {
my $cont = shift;
my @lines = split(/\n/, $cont);
my @links;
foreach my $line (@lines) {
if ($line =~ /()/) {
my $link = $1;
push(@links,$link);
}
}
return @links;
}
sub get_title {
my @links = @_;
my @titles;
foreach my $link (@links) {
if ($link =~ /(.*)<\/a>/){
my $title = $1;
push (@titles,$title);
}
}
}
sub get_rel {
my @links = @_;
my %rel;
my $link_name;
foreach my $link (@links) {
if ($link =~ /href=['"](.*?)['"]/) {
$link_name=$1;
}
if ($link =~ /rel=["'](.*?)["']/) {
@{ $rel{$link_name} } = split(/\s/, $1);
}
}
return %rel;
}
sub check_recip {
my $cgi = shift;
my %xfn = @_;
my @keys = keys %xfn;
require LWP::UserAgent;
my $ua = new LWP::UserAgent;
my $content;
my %rel;
foreach my $key (@keys) {
$content = $ua->get($key)->content;
%rel = get_links($content);
%rel = get_rel(%rel);
%rel = get_xfn(%rel);
}
}
sub get_xfn {
my %rel = @_;
my @xfn;
my @keys = keys %rel;
my @friendship = ('contact','acquaintance','friend');
my $physical = 'met';
my @prof = ('colleague','co-worker');
my @geo = ('co-resident','neighbor');
my @family = ('child','parent','sibling','spouse','kin');
my @romantic = ('muse','crush','date','sweetheart');
my $identity = 'me';
my $x=0;
my %xfn;
foreach my $key (@keys) {
$x++;
foreach my $rel (@{ $rel{$key} }){
if ($rel eq $identity) {
push (@xfn, $identity);
#@{ $xfn{$key} } = @xfn;
#@xfn = ();
} #else {
foreach my $friend ( @friendship ) {
if ($rel =~ /\s*$friend\s*/) {
push (@xfn, $friend);
}
}
if ($rel =~ /\s*$physical\s*/) {
push (@xfn, $physical);
}
foreach my $pro (@prof) {
if ($rel =~ /\s*$pro\s*/) {
push (@xfn,$pro);
}
}
foreach my $g(@geo) {
if ($rel =~ /\s*$g\s*/) {
push (@xfn,$g);
}
}
foreach my $fam(@family){
if ($rel =~ /\s*$fam\s*/) {
push (@xfn,$fam);
}
}
foreach my $rom(@romantic) {
if ($rel =~ /\s*$rom\s*/) {
push (@xfn, $rom);
}
}
}
@{ $xfn{$key} } = @xfn;
@xfn = ();
#}
}
return %xfn;
}