#!/usr/bin/perl -w -I.

# wurfl.cgi

# Based on the programming examples for WUFLLite.pm written
# by Rainer Hillebrand, rainer.hillebrand@webcab.de.
# The latest version can be found at:  http://webcab.de/WURFL/

use CGI;
use WURFLLite;

my $cgi = new CGI;

my $ua = $cgi->http('HTTP_USER_AGENT');

my %wurfl;
my $content = '';

open INPUT, "< ./wurfl.xml";
while (<INPUT>) { $content .= $_;} 
close INPUT;

parseXML(\%wurfl, \$content);

# Search for the User Agent and return the device ID

my $best_device_id = '';
my $best_user_agent = '';
my $best_ua_length = 0;

my $device_id = '';

foreach my $device_id (keys %{$wurfl{'devices'}}) {

   my $dev_user_agent = $wurfl{'devices'}->{$device_id}->{'attributes'}->{'user_agent'};

   if(not defined $dev_user_agent or $dev_user_agent eq '') {
	next;
   }

   if( $ua =~ m|^\Q${dev_user_agent}\E| and
       length($dev_user_agent) > $best_ua_length) {
       $best_device_id  = $device_id;
       $best_user_agent = $dev_user_agent;
       $best_ua_length  = length($dev_user_agent);
   }
}

$device_id = $best_device_id;

if (not defined %{$wurfl{'devices'}->{$device_id}}) {
    # Device not found
    exit;
}


# Build the list of fallback device ids

my @device_ids = ($device_id);
my $dev = $device_id;

while ($dev = $wurfl{'devices'}->{$dev}->{'attributes'}->{'fall_back'}
       and $dev ne 'root') {
   push @device_ids, $dev;
}


# Build a hash of the capabilities of the device using
# the fallback list, starting with the most generic

my %caps = ();

while ($dev = pop(@device_ids)) {

    my $dev_caps = $wurfl{'devices'}->{$dev}->{'capabilities'};

    foreach my $group ( keys (%{$dev_caps})) {

       foreach my $cap ( keys (%{${dev_caps}->{$group}})) {

          $caps{$group}->{$cap} = ${dev_caps}->{$group}->{$cap};
       }
    }
}


# Return the information as WML

print qq[Content-type: text/vnd.wap.wml\n\n];

print qq[<?xml version="1.0"?>\n];
print qq[<!DOCTYPE wml PUBLIC "-//WAPFORUM//DTD WML 1.1//EN" "http://www.wapforum.org/DTD/wml_1.1.xml">\n];

print qq[<wml>\n];
print qq[<card id="main" title="Wurfl test">\n];
print qq[<p>\n];
print qq[WURFL Test - WML<br/>\n];

print qq[<b>Device ID</b> $device_id <br/>];
print qq[<b>User Agent</b> $ua <br/>];

print qq[<b>Rows</b>] . $caps{'display'}->{'rows'} . qq[<br/>];
print qq[<b>Cols</b>] . $caps{'display'}->{'columns'} . qq[<br/>];

my $height = $caps{'display'}->{'resolution_height'};
my $width  = $caps{'display'}->{'resolution_width'};

print qq[<b>Display Height</b>] . $height . qq[<br/>];
print qq[<b>Display Width</b>]  . $width . qq[<br/>];

print qq[<br/>\n];

print qq[<img src="/mobile/ora/line.wbmp" alt="line" width="$width" height="10"/>];

print qq[</p>\n];
print qq[</card></wml>\n];

exit;