# Perl binding to API given in http://www.w3.org/2005/MWI/DDWG/drafts/api/080215
# (c) Rotan Hanrahan 2008
# This code is not guaranteed fit for any purpose whatsoever. Use at your own risk.

################################################################################
## Part 1                                                                      #
## This section shows how a Perl programmer would use the DDR Simple API       #
## Demonstrates:                                                               #
##   - Use of SimpleService methods to interact with DDR.                      #
##   - Getting single property value and collections of property values.       #
##   - Use of property term names and aspect names.                            #
##   - Catching exceptions thrown by the DDR.                                  #
################################################################################

# Instantiate new SimpleService
$ss = SimpleService->new();
$ss->initialize('DDRCoreVocabularyIRI'); # Todo : plugin classname for custom impl

# Populate new instance of Evidence
my $e = Evidence->new();
$e->put('User-Agent','Mozthing1.2e (X11; en-US; v12)');
$e->put('Accept','text/html, image/png, image/jpeg, image/gif, image/x-xbitmap, */*');

print "Evidence from the delivery context:\n";
print '  User-Agent: ' . $e->get('User-Agent') . "\n";
print '  Accept: '     . $e->get('Accept')     . "\n";

# Names of the aspects in which we are interested
my $softwareAspect = $ss->newAspectName('WebBrowser');
my $hardwareAspect = $ss->newAspectName('Device');

# Two browser display properties of interest: Height and Width
my $heightPropName = $ss->newPropertyName('displayHeight');
my $widthPropName = $ss->newPropertyName('displayWidth');
my $propArray = [$heightPropName,$widthPropName];

# Get the values for these properties in this aspect given this evidence
print "Getting specific software values for this context:\n";
my $spvsSW = $ss->getPropertyValues($e,$softwareAspect,$propArray);
print "  Browser Display Height : " . $spvsSW->getValue($heightPropName) . "\n";
print "  Browser Display Width  : " . $spvsSW->getValue($widthPropName) . "\n";

# Get the values for these properties in this aspect given this evidence
# This demonstrates exception catching for case where one or both properties are not available
eval {
  print "Getting specific hardware values for this context:\n";
  my $spvsHW = $ss->getPropertyValues($e,$hardwareAspect,$propArray);
  print "  Physical Display Height : " . $spvsHW->getValue($heightPropName) . "\n";
  print "  Physical Display Width  : " . $spvsHW->getValue($widthPropName) . "\n";
};
if ($@) {
  if ($@->isa('NameException')) {
    print " * * Caught NameException: " . $@->getMessage() . "\n";
  }
}

# Get all known data
print "Getting all values for this context:\n";
my $spvsAll = $ss->getPropertyValues($e);
my @allProperties = @{$spvsAll->getAll()};
foreach my $spv (@allProperties) {
  print '  ' . $spv->getPropertyName() . ' is ' . $spv->getString() . "\n";
}

# Get image support information
print "Getting image format support for this context:\n";
my $imgFmtPropName = $ss->newPropertyName('imageFormatSupport');
my $spv = $ss->getPropertyValue($e,$imgFmtPropName);
my @supportedImageFormats = @{$spv->getEnumeration()};
foreach my $imgFmt (@supportedImageFormats) {
  print '  ' . $imgFmt . " is supported\n";
}

# All-in-one: get the physical height of the device
print "Getting information via a single complex line of code:\n";
print "  Device Height = " . $ss->getPropertyValue($e,$ss->newAspectName('Device'),$ss->newPropertyName('displayHeight'))->getString() . "\n";



################################################################################
## Part 2                                                                      #
## Shows how a typical Perl programmer might wrap the DDR Simple API to make   #
## use of the defaults, and pre-populate common parameters for re-use.         #
## Two subroutines are defined: convenienceInit() and getPropVal(e,a,p)        #
################################################################################

# The way Perl hackers might do this using convenience methods
convenienceInit();
print "Getting information via convenience methods:\n";
print "  Device Height = " . getPropVal($e,'Device','displayHeight')->getInteger() . "\n";
print "  Device Width = "  . getPropVal($e,'Device','displayWidth')->getInteger()  . "\n";
print "  Image formats = " . join(',',@{getPropVal($e,'WebBrowser','imageFormatSupport')->getEnumeration()}) . "\n";

exit 1;



# These convenience methods might be hidden away in a custom Perl module
sub convenienceInit {
  %DDRAspects = (
    'Device' => AspectName->new('Device'),
    'WebBrowser' => AspectName->new('WebBrowser')
  );
  %DDRProps = (
    'displayWidth' => PropertyName->new('displayWidth'),
    'displayHeight' => PropertyName->new('displayHeight'),
    'imageFormatSupport' => PropertyName->new('imageFormatSupport')
  );
  $ddrSrv = SimpleService->new();
  $ddrSrv->initialize('DDRCoreVocabularyIRI');
  $DDRNullValue = SimplePropertyValue->new('NULL','000');
}
sub getPropVal {
  my ($ev,$a,$p) = @_;
  my $result;
  eval { $result = $ddrSrv->getPropertyValue($ev,$DDRAspects{$a},$DDRProps{$p}); };
  if ($@ || !$result->exists()) { return $DDRNullValue; }
  return $result;
}

# ==== END OF USER CODE ====





################################################################################
## Part 3                                                                      #
## This is a set of Perl packages that implement the DDR Simple API.           #
## Public methods are marked thus in comments: [DDR Simple API]                #
################################################################################



# ==== START OF API PACKAGES ====

# ------------------------------------------------------------------
package SimpleService;

use Scalar::Util qw(blessed);

# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my $this = {};
  bless $this, $pkg;
  return $this;
}

# [DDR Simple API]  public void initialize(String defaultVocabularyIRI, Properties props) throws SystemException; // Vocabulary cannot be 'null'
sub initialize {
  my $this = shift;
  $this->{DEFAULTVOCABULARY} = shift;
  if (@_) {
    my $properties = shift; # In Perl, a Properties object is typically a hash
    $this->{PROPS} = \$properties;
  }
  $this->{REPOSITORY} = CustomDDRImplementation->new();
}

# [DDR Simple API]  public SimplePropertyValues getPropertyValues(Evidence evidence) throws SystemException;
# [DDR Simple API]  public SimplePropertyValues getPropertyValues(Evidence evidence, PropertyName[] properties) throws NameException,SystemException;
# [DDR Simple API]  public SimplePropertyValues getPropertyValues(Evidence evidence, AspectName aspect) throws SystemException;
# [DDR Simple API]  public SimplePropertyValues getPropertyValues(Evidence evidence, AspectName aspect, PropertyName[] properties) throws NameException,SystemException;
sub getPropertyValues {
  my $this = shift;
  my $paramCount = @_;
  my ($p1,$p2,$p3) = @_;
  if ($paramCount == 1 && $p1->isa('Evidence')) {
    return _getPropertyValues_Evidence($this,$p1);
  }
  if ($paramCount == 2) {
    if ($p1->isa('Evidence') && !blessed($p2) && ref($p2) == 'ARRAY') {
      return _getPropertyValues_Evidence_ARRAY($this,$p1,$p2);
    }
    if ($p1->isa('Evidence') && $p2->isa('AspectName')) {
      return _getPropertyValues_Evidence_AspectName($this,$p1,$p2);
    }
  }
  if ($paramCount == 3 && $p1->isa('Evidence') && $p2->isa('AspectName') && !blessed($p3) && ref($p3) == 'ARRAY') {
    return _getPropertyValues_Evidence_AspectName_ARRAY($this,$p1,$p2,$p3);
  }
  die('Method signature unknown');
}

sub _getPropertyValues_Evidence {
  my $this     = shift;
  my $evidence = shift;
  my $spvs = SimplePropertyValues->new();
  my @knownvocabularies = @{$this->{REPOSITORY}->getVocabularies()};
  foreach my $vocab (@knownvocabularies) {
    my @props = @{$this->{REPOSITORY}->getPropertyNames($vocab)};
    foreach my $prop (@props) {
      # As PropertyName objects don't know the aspect to which they apply,
      # this implementation will retrieve properties according to their
      # implementation-specific default aspects, where more than one applies.
      my $aspect = $this->{REPOSITORY}->getDefaultAspect($prop,$vocab);
      my $pn = $this->newPropertyName($prop);
      my $aspectName = $this->newAspectName($aspect);
      my $propertyValue = $this->{REPOSITORY}->getValue($evidence,$pn,$aspectName);
      if (defined $propertyValue) {
        $spvs->setValue($pn,$propertyValue);
      }
    }
  }
  return $spvs;
}

sub _getPropertyValues_Evidence_ARRAY {
  my $this              = shift;
  my $evidence          = shift;
  my $propertyNameARRAY = shift;
  die 'Not Implemented';
  # To Do
}

sub _getPropertyValues_Evidence_AspectName {
  my $this       = shift;
  my $evidence   = shift;
  my $aspectName = shift;
  die 'Not Implemented';
  # To Do
}

sub _getPropertyValues_Evidence_AspectName_ARRAY {
  my $this              = shift;
  my $evidence          = shift;
  my $aspectName        = shift;
  my $propertyNameARRAY = shift;
  my $spvs = SimplePropertyValues->new();
  foreach my $pn (@{$propertyNameARRAY}) {
    die SystemException->new('PropertyName[] contained a non-PropertyName element') if !$pn->isa('PropertyName');
    my $propertyValue = $this->{REPOSITORY}->getValue($evidence,$pn,$aspectName);
    if (defined $propertyValue) {
      $spvs->setValue($pn,$propertyValue);
    }
  }
  return $spvs;
}

# [DDR Simple API]  public SimplePropertyValue getPropertyValue(Evidence evidence, PropertyName propertyName) throws NameException,SystemException;
# [DDR Simple API]  public SimplePropertyValue getPropertyValue(Evidence evidence, AspectName aspect,PropertyName propertyName) throws NameException,SystemException;
sub getPropertyValue {
  my $this = shift;
  my $paramCount = @_;
  my ($evidence,$p2,$p3) = @_;
  if ($paramCount == 2) {
    $p3 = $p2;
    $p2 = AspectName->new($this->{REPOSITORY}->getDefaultAspect($p3->getName(),$this->{DEFAULTVOCABULARY}));
    $paramCount = 3;
  }
  if ($paramCount == 3) {
    my $propertyValue = $this->{REPOSITORY}->getValue($evidence,$p3,$p2);
    my $spv = SimplePropertyValue->new($p3->getName(),$propertyValue);
    return $spv;
  }
}

# [DDR Simple API]  public PropertyName newPropertyName(String localPropertyName) throws NameException;
# [DDR Simple API]  public PropertyName newPropertyName(String vocabularyIRI, String localPropertyName) throws NameException;
sub newPropertyName {
  my $this = shift;
  my $paramCount = @_;
  my ($p1,$p2) = @_;
  if ($paramCount == 1) {
    return PropertyName->new($p1,$this->{DEFAULTVOCABULARY});
  }
  if ($paramCount == 2) {
    return PropertyName->new($p1,$p2);
  }
  return undef;
}

# [DDR Simple API]  public AspectName newAspectName(String aspectIRI) throws NameException;
sub newAspectName { shift; return AspectName->new(shift); }

# [DDR Simple API]  public AspectName[] listAspects() throws SystemException;
# [DDR Simple API]  public PropertyName[] listProperties(String vocabularyIRI) throws SystemException;
# [DDR Simple API]  public String[] listVocabularies() throws SystemException;

# ------------------------------------------------------------------
package Evidence;

# public interface Evidence extends Map { }
# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my %map; # an empty hash map
  my $evidence = bless { 'map' => %map }, $pkg;
  return $evidence;
}

# "put" is an assumed method of Map
sub put {
  my ($evidence,$key,$val) = @_;
  my $map = \$evidence->{'map'};
  $map{$key} = $val;
}

# "get" is an assumed method of Map
sub get {
  my ($evidence,$key) = @_;
  my $map = \$evidence->{'map'};
  return $map{$key};
}

# ------------------------------------------------------------------
package AspectName;

# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my $name = shift;
  my $this = {};
  bless ($this, $pkg);
  $this->{NAME} = $name;
  return $this;
}

# [DDR Simple API]  public String getName();
sub getName {
  my $this = shift;
  return $this->{NAME};
}

# ------------------------------------------------------------------
package PropertyName;

# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my $name = shift;
  my $this = {};
  bless ($this, $pkg);
  $this->{NAME} = $name;
  if (@_) {
    my $namespace = shift;
    $this->{NAMESPACE} = $namespace;
  }
  else {
    $this->{NAMESPACE} = 'DDRCoreVocabularyIRI'; # Seems reasonable, right?
  }
  return $this;
}

# [DDR Simple API]  public String getName()
sub getName {
  my $this = shift;
  return $this->{NAME};
}

# [DDR Simple API]  public String getNamespace()
# Returns the IRI of the vocabulary to which this named property belongs
sub getNamespace {
  my $this = shift;
  return $this->{NAMESPACE};
}

# ------------------------------------------------------------------
package SimplePropertyValues;

# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my $name = shift;
  my $this = {};
  bless ($this, $pkg);
  return $this;
}

# [DDR Simple API]  public SimplePropertyValue[] getAll()
sub getAll {
  my $this = shift;
  my @allPropertyValues = ();
  foreach my $propName (sort keys %{$this}) {
    my $value = $this->{$propName};
    my $spv = SimplePropertyValue->new($propName,$value);
    push(@allPropertyValues,$spv);
  }
  return \@allPropertyValues;
}

# [DDR Simple API]  public SimplePropertyValue getValue(PropertyName prop) throws NameException
sub getValue {
  my $this = shift;
  my $prop = shift; die('Got ' . ref($prop) . ' when expecting PropertyName') if ref($prop) != 'PropertyName';
  my $name = $prop->getName();
  my $value = $this->{$name};
  if (!defined $value) { die NameException->new("$name not found." ); }
  return $value;
}

# Not part of public interface specification
# Assumed to be implementation dependent and private
sub setValue {
  my $this  = shift;
  my $prop  = shift; # assume to be a PropertyName object
  my $value = shift; # assume to be a SimplePropertyValue object
  $this->{$prop->getName()} = $value;
}

# ------------------------------------------------------------------
package SimplePropertyValue;

# Constructor is not part of official specification
sub new {
  my $pkg   = shift;
  my $name  = shift;
  my $value = shift;
  my $this = {};
  bless ($this, $pkg);
  $this->{NAME} = $name;
  $this->{VALUE} = $value;
  return $this;
}

# [DDR Simple API]  public String getString() throws ValueException;
sub getString {
  my $this = shift;
  my $value = $this->{VALUE};
  if (defined($value)) {
    return '' . $value;
  }
  else {
    die ValueException->new('no value exists for this property');
  }
}

# [DDR Simple API]  public boolean getBoolean() throws ValueException;
sub getBoolean {
  my $this = shift;
  my $value = $this->{VALUE};
  if (defined($value)) {
    return $value?1:0; # Perl doesn't have an internal Boolean representation!
  }
  else {
    die ValueException->new('no value exists for this property');
  }
}

# [DDR Simple API]  public int getInteger() throws ValueException;
sub getInteger {
  my $this = shift;
  my $value = $this->{VALUE};
  if (defined($value)) {
    return 0 + $value;
  }
  else {
    die ValueException->new('ValueException: no value exists for this property');
  }
}

# [DDR Simple API]  public String[] getEnumeration() throws ValueException;
sub getEnumeration {
  my $this = shift;
  my $value = $this->{VALUE};
  if (defined($value)) {
    if (ref($value) eq 'ARRAY') {
      return $value;
    }
    else {
      return [ $value ]; # put single value into a single-cell array
    }
  }
  else {
    die ValueException->new('ValueException: no appropriate value exists for this property');
  }
}
# [DDR Simple API]  public float getFloat() throws ValueException;
# To Do
# [DDR Simple API]  public double getDouble() throws ValueException;
# To Do
# [DDR Simple API]  public long getLong() throws ValueException;
# To Do

# [DDR Simple API]  public PropertyName getPropertyName();
sub getPropertyName {
  my $this = shift;
  return $this->{NAME};
}

# [DDR Simple API]  public boolean exists();
sub exists {
  my $this = shift;
  return defined($this->{VALUE});
}



################################################################################
## Part 4                                                                      #
## Exceptions thrown by various DDR Simple API methods.                        #
################################################################################


# = = = = = = EXCEPTION CLASSES = = = = = = = = = = = = = = = = = = =

# ------------------------------------------------------------------
package BaseException;

sub new {
  my $pkg = shift;
  my $message = shift;
  my $self = bless { MESSAGE => $message }, $pkg;
  return $self;
}

sub getMessage {
  my $this = shift;
  return $this->{MESSAGE};
}

# ------------------------------------------------------------------
package SystemException;
BEGIN { @SystemException::ISA = qw( BaseException ); }

# ------------------------------------------------------------------
package NameException;
BEGIN { @NameException::ISA = qw( BaseException ); }

# ------------------------------------------------------------------
package ValueException;
BEGIN { @ValueException::ISA = qw( BaseException ); }




################################################################################
## Part 6                                                                      #
## A custom implementation of the back-end logic that retrieves actual data.   #
## Actual implementations of this part would probably interact with a database #
## or expert system, or fuzzy logic or some other proprietary system.          #
## This example hard-codes the data in-situ and does not connect elsewhere.    #
## Only three of the DDR Core Vocabulary property terms are represented here.  #
## Context recognition depends solely on matching the User-Agent evidence.     #
## Three pseudo-devices are hard-coded in this collection of device data.      #
## Unknown/unavailable data is represented as 'undef'.                         #
################################################################################



# CUSTOM REPOSITORY IMPLEMENTATION
# (Barely functional!)

# ------------------------------------------------------------------
package CustomDDRImplementation;

# Intentionally inefficient storage of device descriptions.
# Intentionally poor device recognition.
# If you want professional implementations, make or buy them.
sub new {
  my $pkg   = shift;
  my $this = {};
  bless ($this, $pkg);
  $this->{VOCABULARIES} = [ 'DDRCoreVocabularyIRI' ];
  $this->{ASPECTS} = [ 'Device', 'WebBrowser' ];
  $this->{USERAGENTS} = [
    'EI-emu (Gekoo; X11; watzit)',
    'Mozthing1.2e (X11; en-US; v12)',
    'Opella99 (Dash2; en-UK; mod-4; patched) nosuch/1255'
  ];
  $this->{'DDRCoreVocabularyIRI'} = {
    'displayHeight' => {
      'Device'     => [ 260, 800, 140 ],
      'WebBrowser' => [ 240, 788, 136 ],
      'DEFAULT'    => 'Device'                       # Arbitrary choice
    },
    'displayWidth' => {
      'Device'     => [ 180, undef, 280 ],
      'WebBrowser' => [ 160, 1012,  276 ],
      'DEFAULT'    => 'Device'                       # Arbitrary choice
    },
    'imageFormatSupport' => {
      'WebBrowser' => [
        [ 'gif87',  'gif89a', 'jpeg', 'png', ],
        [ 'gif89a', 'jpeg',   'png',         ],
        [ 'gif87',  'gif89a', 'jpeg',        ]
      ],
      'DEFAULT'    => 'WebBrowser'                   # This is the only aspect
    }
  };
  return $this;
}

sub _getValueDirect {
  my $this       = shift;
  my $useragent  = shift; # just an ordinary string
  my $vocabulary = shift; # just an ordinary string
  my $property   = shift; # just an ordinary string
  my $aspect     = shift; # just an ordinary string
  my @agents = @{$this->{USERAGENTS}};
  my $lastUAindex = $#agents;
  my $i = 0;
  while ($i <= $lastUAindex && $agents[$i] ne $useragent) {
    $i++;
  }
  if ($i <= $lastUAindex) {
    return $this->{$vocabulary}->{$property}->{$aspect}[$i];
  }
  return undef;
}

sub getValue {
  my $this         = shift;
  my $evidence     = shift;
  my $propertyName = shift;
  my $aspectName   = shift;
  my $ua   = $evidence->get('User-Agent');
  my $voc  = $propertyName->getNamespace();
  my $prop = $propertyName->getName();
  my $asp  = $aspectName->getName();
  return _getValueDirect($this,$ua,$voc,$prop,$asp);
}

# returns all vocabularies (IRIs) supported by this custom implementation
sub getVocabularies {
  my $this = shift;
  return $this->{VOCABULARIES};
}

# returns all property names for the given vocabulary IRI
sub getPropertyNames {
  my $this       = shift;
  my $vocabulary = shift;
  my %v = %{$this->{$vocabulary}};
  my @result = sort keys %v;
  return \@result;
}

# returns all aspects supported by this custom implementation
sub getAspects {
  my $this = shift;
  return $this->{ASPECTS};
}

# returns the default aspect for a named property in the given vocabulary
sub getDefaultAspect {
  my $this       = shift;
  my $property   = shift;
  my $vocabulary = shift;
  return $this->{$vocabulary}->{$property}->{DEFAULT};
}

################################################################################
## Output                                                                      #
## When executed, the above program generates the following output:            #
##                                                                             #
## Evidence from the delivery context:                                         #
##   User-Agent: Mozthing1.2e (X11; en-US; v12)                                #
##   Accept: text/html, image/png, image/jpeg, image/gif, image/x-xbitmap, */* #
## Getting specific software values for this context:                          #
##   Browser Display Height : 788                                              #
##   Browser Display Width  : 1012                                             #
## Getting specific hardware values for this context:                          #
##   Physical Display Height : 800                                             #
##  * * Caught NameException: displayWidth not found.                          #
## Getting all values for this context:                                        #
##   displayHeight is 800                                                      #
##   imageFormatSupport is ARRAY(0x1f8f19c)                                    #
## Getting image format support for this context:                              #
##   gif89a is supported                                                       #
##   jpeg is supported                                                         #
##   png is supported                                                          #
## Getting information via a single complex line of code:                      #
##   Device Height = 800                                                       #
## Getting information via convenience methods:                                #
##   Device Height = 800                                                       #
##   Device Width = 0                                                          #
##   Image formats = gif89a,jpeg,png                                           #
##                                                                             #
################################################################################