#!/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; }