Favicon API α版の代わりに自サイトにAPIを設置する

Tweet

Favicon API (ファビコン) α版 [favicon.aruko.net] が正式に休止中になりました。おそらくみんなただで使いまくったせいだと思う。僕も使っていたのでごめんなさい。

そんで、会社でも盛大に使っていたので、PAGE 2009開催中で会社のサイトに来訪が多かったにもかかわらずFaviconが盛大に表示されていなかったという悲しい状態になっていたのを受けて、PAGE 2009から帰ってきた同僚君から「これ設置してー」としてもらったのが、Dan Kogaiのスクリプト。

404 Blog Not Found:perl - 任意のURIからfaviconを取得するAPI [blog.livedoor.jp]

このスクリプトは、TinyURLの亜種みたいなかんじで、URLを指定すると、Faviconのありかを探し出し、リダイレクトをして、リダイレクト先をDBに格納するというものです。2回目はDBからリダイレクト先をそのまま返す。

というわけで、設置したのですけれども、同僚君から、「IE6/IE7だと、表示されんよ。」というので、「そら、WindowsのICOだったらimg要素で出ないと思うよー」といったら「でるようにして」っていわれましたので、作ってみましたー

Filename: favicon.cgi

#!/usr/local/bin/perl
#
# $Id: favicon.cgi,v 0.5 2009/02/11 14:40:02 CL $
# original: http://api.dan.co.jp/favicon.src
#
use strict;
use warnings;
use CGI;
use CGI::Carp qw/fatalsToBrowser/;
use DB_File;
use Fcntl;
use HTML::Parser;
use LWP::UserAgent;
use Image::Magick;
use Digest::MD5;
 
# Config parameters -- customize those
my $basedir = '/var/www/html/favicon';
my $dbfile = "$basedir/.favicon/favicon.db";
my $ttl    = 86400;
my $icondir = 'icons';
my $baseurl = 'http://example.com/favicon';
 
# agent name
our $VERSION = sprintf "%d.%02d", q$Revision: 0.5 $ =~ /(\d+)/g;
my $agent = $0;
$agent =~ s,.*/,,o;
$agent .= "/$VERSION";
 
no warnings 'uninitialized';
my $q   = CGI->new;
my $uri = $ENV{PATH_INFO};
$uri =~ s,^/,,o or die 'invalid uri: ', $q->escapeHTML($uri);
$uri =~ m,^https?://,o or die 'invalid scheme: ', $q->escapeHTML($uri);
$uri .= '?' . $ENV{QUERY_STRING} if $ENV{QUERY_STRING};
my ($favicon_uri, $lastmod) = get_favicon($uri, $dbfile, $ttl);
if ($favicon_uri){
    print $q->redirect(-uri    => $favicon_uri,
		       -status => 301,
		       -x_last_checked => scalar localtime $lastmod);
}else{
    print $q->header(-status => 404,
		     -x_last_checked => scalar localtime $lastmod);
}
 
sub get_favicon{
    my $uri = URI->new(shift);
    my ($dbfile, $ttl) = @_;
    my ($furi, $lastmod) = get_cache($uri, $dbfile);
    # 0th attempt; via db
    return ($furi, $lastmod) if $lastmod and time() - $lastmod < $ttl;
    # 1st attempt; via <link rel="shortcut icon">
    my $ua = LWP::UserAgent->new( timeout    => 15,
				  keep_alive => 4,
				  agent      => $agent);
    # just check first 4096 bytes;
    my $req = HTTP::Request->new(GET => $uri);
    $req->headers->header(Range => "bytes=0-4095");
    # warn $req->as_string;
    my $res = $ua->request($req);
    # warn $res->status_line;
    return set_cache($uri => '', $dbfile) unless $res->is_success;
    if ($res->header('Content-Type') =~ m,text/(?:x|ht)ml,io){
	my $start_h = sub{
	    my ($self, $tagname, $attr) = @_;
	    return unless $tagname eq 'link';
	    return unless $attr->{rel} =~ /\A(shortcut )?icon\z/i;
	    $furi = URI->new($attr->{href})->abs($uri); 
	    $self->eof;
	};
   	my $hp = HTML::Parser->new(start_h => 
				   [ $start_h => "self,tagname,attr" ]);
	$hp->parse($res->content);
	return set_cache($uri => $furi, $dbfile) if $furi;
    }
    # 2nd attempt; top-level;
    $furi = $uri->clone;
    $furi->path_query("/favicon.ico");
    $res = $ua->head($furi);
    return set_cache($uri => $furi, $dbfile) if($res->is_success);
    # sorry, no favicon
    return set_cache($uri => '', $dbfile);
}
 
sub get_cache($$){
    my ($uri, $dbfile) = @_;
    tie my %favicon_of, 'DB_File', $dbfile, 
    O_RDONLY|O_NONBLOCK|O_SHLOCK, 0444, $DB_HASH
	or return;
    my ($furi, $lastmod) = split /\t/, $favicon_of{$uri};
    untie %favicon_of;
    return ($furi, $lastmod);
}
 
sub set_cache($$$){
    my ($uri, $furi, $dbfile) = @_;
    $furi = check_ico($furi);
    tie my %favicon_of, 'DB_File', $dbfile, 
    O_CREAT|O_RDWR|O_EXLOCK, 0666, $DB_HASH
	or die "$dbfile:$!";
    my $lastmod = time();
    $favicon_of{$uri} = $furi . "\t" . $lastmod;
    untie %favicon_of;
    return ($furi, $lastmod);
}
 
sub check_ico {
	my $furi = shift;
	my $ua = LWP::UserAgent->new( timeout    => 15,
				  keep_alive => 4,
				  agent      => $agent);
	my $res = $ua->get( $furi);
	my $content = $res->content;
	use File::MMagic;
	my $mm = new File::MMagic;
	my $mimetype = $mm->checktype_contents($content);
	if ( $mimetype eq 'application/octet-stream') {
		$furi = convert_ico($content, $furi);
	}
	return $furi;
}
 
sub convert_ico {
	my $content = shift;
	my $uri = shift;
	my $ctx = Digest::MD5->new;
	$ctx->add($uri);
	my $filename = $ctx->hexdigest.'_'.time.'.gif';
	my $filepath = "$basedir/$icondir/$filename";
	{
		open my $fh, ">", $filepath or die $!;
		print $fh $content;
		close $fh;
	}
	my $img = Image::Magick->new();
	$img->Read("ico:$filepath"."[0]");
	$img->Resize(width=>16, height=>16);
	my $img2 = Image::Magick->new();
	$img2->Set(size =>'16x16');
	$img2->ReadImage('xc:white');  
	$img2->Composite(
	  image   =>$img,
	  compose =>'Over',
	  x => '0',     
	  y => '0');    
	$img2->Write("gif:$filepath");
	return "$baseurl/$icondir/$filename";
}

そんで、Windows icon形式の場合どうするかっていうと、単純にgifに変換してWeb公開用ディレクトリに出力する。

このため、ディレクトリや公開URLを設定するようになっています。あと、動けばいい的方針でやってますので、追加したコードはかなりアカンと思います。

2009.02.11 15:05 投稿　大野 義貴 [Perl] | 固定リンク |