# Perl binding to API given in http://www.w3.org/2005/MWI/DDWG/drafts/api/080228
# (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 Service 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 Service
$ss = Service->new();
$ss->initialize('DDRCoreVocabularyIRI',undef); 

print 'Using API (' . $ss->getAPIVersion() . ') with Repository (' . $ss->getDataVersion() . ")\n";

# Populate new instance of Evidence
my $e = $ss->newHTTPEvidence(); #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->getValue('User-Agent') . "\n";
print '  Accept:'      . $e->getValue('Accept')     . "\n";

# Names of the aspects in which we are interested (aspect IRI is same as property IRI)
my $softwareAspect = 'WebBrowser';
my $hardwareAspect = 'Device';

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

# The two properties in the software aspect
my $heightPropRefSW = $ss->newPropertyRef($heightPropName,$softwareAspect);
my $widthPropRefSW = $ss->newPropertyRef($widthPropName,$softwareAspect);
my $propRefArraySW = [ $heightPropRefSW, $widthPropRefSW ];

# The two properties in the hardware aspect
my $heightPropRefHW = $ss->newPropertyRef($heightPropName,$hardwareAspect);
my $widthPropRefHW = $ss->newPropertyRef($widthPropName,$hardwareAspect);
my $propRefArrayHW = [ $heightPropRefHW, $widthPropRefHW ];

# 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,$propRefArraySW);
print "  Browser Display Height : " . $spvsSW->getValue($heightPropRefSW) . "\n";
print "  Browser Display Width  : " . $spvsSW->getValue($widthPropRefSW) . "\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,$propRefArrayHW);
  print "  Physical Display Height : " . $spvsHW->getValue($heightPropRefHW) . "\n";
  print "  Physical Display Width  : " . $spvsHW->getValue($widthPropRefHW) . "\n";
};
if ($@) {
  if ($@->isa('NameException')) {
    print ' * * Caught NameException: [' . $@->getCode() . ': ' . $@->getMessage() . "]\n";
  }
}

# Get all known data
print "Getting all values for this context:\n";
my $pvsAll = $ss->getPropertyValues($e);
my @allProperties = @{$pvsAll->getAll()};
foreach my $pv (@allProperties) {
  my $pRef =$pv->getPropertyRef();
  print '  ' . $pRef->getPropertyName() . ' is ' . $pv->getString() . "\n";   # Have to assume String, no way to tell!
}

# 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 Simple API methods only:\n";
print "  Device Height = " . $ss->getPropertyValue($e,$ss->newPropertyRef($ss->newPropertyName('displayHeight'),'Device'))->getString() . "\n";
print "Getting information via implementation specific constructor:\n";
print "  Device Height = " . $ss->getPropertyValue($e,PropertyRef->new('displayHeight','Device'))->getString() . "\n";
# Most likely convenience method we will be asked for:
# print "  Device Height = " . $ss->getPropertyValue($e,'displayHeight','Device')->getString() . "\n";

# Using the PropertyRef proposal
print "Getting information via PropertyRef:\n";
my $pr = PropertyRef->new('displayHeight','WebBrowser');
print '  Browser height = ' . $ss->getPropertyValue($e,$pr)->getInteger() . "\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 custom convenience methods:\n";
print "  Device Height = " . getPropVal($e,'displayHeight','Device')->getInteger() . "\n";
print "  Device Width = "  . getPropVal($e,'displayWidth','Device')->getInteger()  . "\n";
print "  Image formats = " . join(',',@{getPropVal($e,'imageFormatSupport','WebBrowser')->getEnumeration()}) . "\n";

exit 1;

# These convenience methods might be hidden away in a custom Perl module
sub convenienceInit {
  %DDRProps = (
    'displayWidth' => PropertyName->new('displayWidth'),
    'displayHeight' => PropertyName->new('displayHeight'),
    'imageFormatSupport' => PropertyName->new('imageFormatSupport')
  );
  $ddrSrv = Service->new(); 
  $ddrSrv->initialize('DDRCoreVocabularyIRI');
  $DDRNullPropRef = PropertyRef->new('NULL','');
  $DDRNullValue = PropertyValue->new($DDRNullPropRef,'000');
}
sub getPropVal {
  my ($ev,$p,$a) = @_;
  my $result;
  eval { $result = $ddrSrv->getPropertyValue($ev,$DDRProps{$p},$a); };
  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 Service;

use Scalar::Util qw(blessed);
use Carp;

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

# [DDR Simple API]  public String getAPIVersion()
sub getAPIVersion {
  return "1.0.0";
}

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

# [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
    if (defined $properties) {
      $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, String localAspectName) throws NameException,SystemException;
# [DDR Simple API]  public SimplePropertyValues getPropertyValues(Evidence evidence, String localAspectName, String aspectIRI) throws NameException,SystemException;
sub getPropertyValues {
  my $this = shift;
  my $paramCount = @_;
  my ($p1,$p2,$p3) = @_;
  if ($paramCount == 1 && $p1->isa('Evidence')) {                                   # getPropertyValues(Evidence)
    return _getPropertyValues_Evidence($this,$p1);
  }
  if ($paramCount == 2) {
    if ($p1->isa('Evidence') && !blessed($p2) && ref($p2) == 'ARRAY') {             # getPropertyValues(Evidence, PropertyName[])
      return _getPropertyValues_Evidence_ARRAY($this,$p1,$p2);
    }
    else {                                                                          # getPropertyValues(Evidence, String)
      return _getPropertyValues_Evidence_LocalAspectName($this,$p1,$p2);
    }
  }
  if ($paramCount == 3) {                                                           # getPropertyValues(Evidence, String, String)
    return _getPropertyValues_Evidence_LocalAspectName_AspectIRI($this,$p1,$p2,$p3);
  }
  die('Method signature unknown');
}

sub _getPropertyValues_Evidence {
  my $this     = shift;
  my $evidence = shift;
  my $pvs = PropertyValues->new();
  my @knownVocabularyIRIs = @{$this->{REPOSITORY}->getVocabularies()};
  foreach my $vocabularyIRI (@knownVocabularyIRIs) {
    my @localPropertyNames = @{$this->{REPOSITORY}->getPropertyNames($vocabularyIRI)};
    foreach my $localPropertyName (@localPropertyNames) {
      my $defaultAspectForProperty = $this->{REPOSITORY}->getDefaultAspect($localPropertyName,$vocabularyIRI);
      my $propertyName = $this->newPropertyName($localPropertyName);
      my $propertyRef = $this->newPropertyRef($propertyName,$defaultAspectForProperty);
      my $actualPropertyValue = $this->{REPOSITORY}->getValue($evidence,$localPropertyName,$defaultAspectForProperty,$vocabularyIRI);
      if (defined $actualPropertyValue) {
        my $propertyValue = PropertyValue->new($propertyRef,$actualPropertyValue);
        $pvs->setValue($propertyRef,$propertyValue);
      }
    }
  }
  return $pvs;
}

sub _getPropertyValues_Evidence_ARRAY {
  my $this             = shift;
  my $evidence         = shift;
  my $propertyRefARRAY = shift;
  my $vocabularyIRI    = $this->{DEFAULTVOCABULARY};
  my $pvs = PropertyValues->new();
  foreach my $pRef (@{$propertyRefARRAY}) {
    if (!$pRef->isa('PropertyRef')) {
      die SystemException->new('PropertyRef[] contained a non-PropertyRef element');
    }
    my $localPropertyName = $pRef->getPropertyName();
    my $aspect = $pRef->getAspectName();
    if (!defined($aspect) || $aspect eq '') {
      my $aspect = $this->{REPOSITORY}->getDefaultAspect($localPropertyName,$vocabularyIRI);
    }
    my $namespace = $pRef->getNamespace();
    my $propertyValue = $this->{REPOSITORY}->getValue($evidence,$localPropertyName,$aspect,$namespace);
    if (defined $propertyValue) {
      $pvs->setValue($pRef,$propertyValue);
    }
  }
  return $pvs;
}

sub _getPropertyValues_Evidence_LocalAspectName {  # gets all values
  my $this            = shift;
  my $evidence        = shift;
  my $localAspectName = shift;
  my $aspectIRI       = $this->{DEFAULTVOCABULARY}; # In Simple API, aspect IRI defaults to the property IRI
  return $this->_getPropertyValues_Evidence_LocalAspectName_AspectIRI($evidence,$localAspectName,$aspectIRI);
}

sub _getPropertyValues_Evidence_LocalAspectName_AspectIRI { # gets all values
  my $this            = shift;
  my $evidence        = shift;
  my $localAspectName = shift;
  my $aspectIRI       = shift;
  
  my $pvs = PropertyValues->new();
  my @knownVocabularyIRIs = @{$this->{REPOSITORY}->getVocabularies()};
  foreach my $vocabularyIRI (@knownVocabularyIRIs) {
    my @localPropertyNames = @{$this->{REPOSITORY}->getPropertyNames($vocabularyIRI)};
    foreach my $localPropertyName (@localPropertyNames) {
      my $defaultAspectForProperty = $this->{REPOSITORY}->getDefaultAspect($localPropertyName,$vocabularyIRI);
      my $propertyName = $this->newPropertyName($localPropertyName);
      my $propertyRef = $this->newPropertyRef($propertyName,$defaultAspectForProperty);
      my $actualPropertyValue = $this->{REPOSITORY}->getValue($evidence,$localPropertyName,$defaultAspectForProperty,$vocabularyIRI);
      if (defined $actualPropertyValue) {
        my $propertyValue = PropertyValue->new($propertyRef,$actualPropertyValue);
        $pvs->setValue($propertyRef,$propertyValue);
      }
    }
  }
  return $pvs;
  
}

# [DDR Simple API]  public PropertyValue getPropertyValue(Evidence evidence, PropertyName propertyName) throws NameException,SystemException;
# [DDR Simple API]  public PropertyValue getPropertyValue(Evidence evidence, PropertyRef propertyRef) throws NameException,SystemException;
# [DDR Simple API]  public PropertyValue getPropertyValue(Evidence evidence, String propertyName) throws NameException,SystemException;
sub getPropertyValue {
  my $this = shift;
  my ($evidence,$p2) = @_;
  my $localAspectName = undef;
  my $localPropertyName = undef;
  my $propertyRef = undef;
  if (ref($p2) eq 'PropertyName') {                                             # getPropertyValue(Evidence, PropertyName)
    $localAspectName = $this->{REPOSITORY}->getDefaultAspect($p2->getPropertyName(),$this->{DEFAULTVOCABULARY});
    $localPropertyName = $p2->getPropertyName();
    $propertyRef = $this->newPropertyRef($p2,$localAspectName);
  }
  elsif (ref($p2) eq 'PropertyRef') {                                           # getPropertyValue(Evidence, PropertyRef)
    $localAspectName = $p2->getAspectName();
    $localPropertyName = $p2->getPropertyName();
    $propertyRef = $p2;
  }
  else {                                                                        # getPropertyValue(Evidence, String)
    $localAspectName = $this->{REPOSITORY}->getDefaultAspect($p2,$this->{DEFAULTVOCABULARY});
    $localPropertyName = $p2;
    $propertyRef = $this->newPropertyRef($this->newPropertyName($localPropertyName),$localAspectName);
  }
  my $propertyValue = $this->{REPOSITORY}->getValue($evidence,$localPropertyName,$localAspectName,$propertyRef->getNamespace());
  my $pv = PropertyValue->new($propertyRef,$propertyValue);
  return $pv;
}

# [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 PropertyRef newPropertyRef()
# [DDR Simple API]  public PropertyRef newPropertyRef(PropertyName propertyName)
# [DDR Simple API]  public PropertyRef newPropertyRef(ProeprtyName propertyName, String localAspectName)
sub newPropertyRef {
  my $this = shift;
  my ($localPropertyName,$localAspectName) = @_;
  if (defined $localPropertyName) {
    if (defined $localAspectName) {
      return PropertyRef->new($localPropertyName,$localAspectName);
    }
    else {
      return PropertyRef->new($localPropertyName,$PropertyRef::NULL_ASPECT);
    }
  }
  die "Unknown factory signature for newPropertyRef";
}

sub newHTTPEvidence {
  my $this = shift;
  if ($@) {
    return HTTPEvidence->new($@);
  }
  else {
    return HTTPEvidence->new();
  }
}

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

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

sub new {
  my $pkg = shift;
  my %map; # an empty hash map
  my $evidence = bless { 'map' => %map }, $pkg;
  return $evidence;
}

# [DDR Simple API]  public Boolean exists()
sub exists {
  my ($evidence,$key) = @_;
  my $map = \$evidence->{'map'};
  return defined($map{$key});
}

# [DDR Simple API]  public String getValue(String)
sub getValue {
  my ($evidence,$key) = @_;
  my $map = \$evidence->{'map'};
  return $map{$key};
}

# [DDR Simple API]  public void put(String key, String value)
sub put {
  my ($evidence,$key,$val) = @_;
  my $map = \$evidence->{'map'};
  $map{$key} = $val;
}


# ------------------------------------------------------------------
package HTTPEvidence;
BEGIN { @HTTPEvidence::ISA = qw( Evidence ); }

# public interface Evidence extends Map { }
# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg = shift;
  my %map; # an empty hash map
  if ($@) {
    my $headers = shift; # assume this is a ref to a hash
    %map = %{$headers};
  }
  my $evidence = bless { 'map' => %map }, $pkg;
  return $evidence;
}

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

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

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

# [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};
}

# Implementation-specific method
sub _hash {
  my $this = shift;
  return $this->{NAMESPACE} . ':' . $this->{LOCALNAME};
}

# ------------------------------------------------------------------
package PropertyRef;

# Constructor is not part of SimpleAPI specification
sub new {
  my $pkg      = shift;
  my $property = shift;
  my $aspect   = shift;
  my $this = bless {}, $pkg;
  if (ref($property) eq 'PropertyName') {
    $this->{PROPERTYNAME} = $property;
  }
  else {
    $this->{PROPERTYNAME} = PropertyName->new($property);
  }
  # In an advanced version, aspect would be a special class
  $this->{LOCALASPECTNAME} = $aspect;
  return $this;
}

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

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

# [DDR Simple API]  public String getNamespace()
sub getNamespace {
  my $this = shift;
  my $namespace = $this->{PROPERTYNAME}->getNamespace();
  if (!defined($namespace)) {
    return $PropertyRef::NULL_ASPECT;
  }
  else {
    return $namespace;
  }
}

# [DDR Simple API]
$PropertyRef::NULL_ASPECT = '_-NULL-_';

# Implementation-specific method
sub _hash {
  my $this = shift;
  return $this->{PROPERTYNAME}->_hash() . '::' . $this->{LOCALASPECTNAME};
}

# ------------------------------------------------------------------
package PropertyValues;

# 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 PropertyValue[] getAll()
sub getAll {
  my $this = shift;
  my @allPropertyValues = ();
  foreach my $hash (sort keys %{$this}) {
    my $propertyValue = $this->{$hash};
    push(@allPropertyValues,$propertyValue);
  }
  return \@allPropertyValues;
}

# [DDR Simple API]  public PropertyValue getValue(PropertyRef prop) throws NameException
sub getValue {
  my $this = shift;
  my $pRef = shift; die('Got ' . ref($pRef) . ' when expecting PropertyRef') if ref($pRef) != 'PropertyRef';
  my $hash = $pRef->_hash();
  my $value = $this->{$hash};
  if (!defined $value) {
    die NameException->new($NameException::PROPERTY_NOT_RECOGNIZED,$pRef->getPropertyName() . " not found." );
  }
  return $value;
}

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

# ------------------------------------------------------------------
package PropertyValue;

# Constructor is not part of official specification
sub new {
  my $pkg         = shift;
  my $pRef        = shift;
  my $actualValue = shift;
  my $this = {};
  bless ($this, $pkg);
  $this->{PROPERTYREF} = $pRef;
  $this->{VALUE} = $actualValue;
  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 getPropertyRef {
  my $this = shift;
  return $this->{PROPERTYREF};
}

# [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 = = = = = = = = = = = = = = = = = = =

# ------------------------------------------------------------------
# BaseException is implementation-specific. (Not part of DDR API)
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 DDRException;
BEGIN { @DDRException::ISA = qw( BaseException ); }

use Carp;

# DDRException()
# DDRException(int code, String message)
# DDRException(int code, Throwable thr)    // Throwable is not a Perl type
sub new {
  my $pkg = shift;
  my $self = bless { }, $pkg;
  if (@_) {
    my $code = shift;
    $self->{CODE} = $code;
    if (@_) {
      my $message = shift;      # assume a message string. Throwable not supported/.
      $self->{MESSAGE} = $message;
    }
  }
  ($cpkg, $cfile, $cline) = caller;
  #print "$pkg created by $cpkg at line $cline. (" . $self{MESSAGE} . ")\n";
  #confess();
  return $self;
}

# [DDR Simple API]  public int getCode()
sub getCode {
  my $this = shift;
  return $this->{CODE};
}

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

# ------------------------------------------------------------------
package NameException;
BEGIN {
  @NameException::ISA = qw( DDRException );
  # [DDR Simple API]
  $ASPECT_NOT_RECOGNIZED     = 800;
  $PROPERTY_NOT_RECOGNIZED   = 100;
  $VOCABULARY_NOT_RECOGNIZED = 200;
}

# ------------------------------------------------------------------
package SimpleException;
BEGIN { @SimpleException::ISA = qw( DDRException ); }

# ------------------------------------------------------------------
package SystemException;
BEGIN {
  @SystemException::ISA = qw( DDRException );
  # [DDR Simple API]
  $CANNOT_PROCEED = 500;
  $INITIALIZATION = 400;
}


# ------------------------------------------------------------------
package ValueException;
BEGIN {
  @ValueException::ISA = qw( DDRException );
  # [DDR Simple API]
  $INCOMPATIBLE_TYPES =  600;
  $MULTIPLE_VALUES    = 1000;
  $NOT_KNOWN          =  900;
}

################################################################################
## 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->{DATAVERSION} = '080228';
  $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 ],                # width of Mozthing1.2e Device is unknown
      '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 $localPropertyName = shift;
  my $localAspectName   = shift;
  my $namespace         = shift;
  my $ua = $evidence->getValue('User-Agent');
  return _getValueDirect($this,$ua,$namespace,$localPropertyName,$localAspectName);
}

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

sub getDataVersion {
  my $this = shift;
  return $this->{DATAVERSION};
}

################################################################################
## Output                                                                      #
## When executed, the above program generates the following output:            #
##                                                                             #
## Using API (1.0.0) with Repository (080228)                                  #
## 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: [100: displayWidth not found.]                   #
## Getting all values for this context:                                        #
##   displayHeight is 800                                                      #
##   imageFormatSupport is ARRAY(0x1f38914)                                    #
## Getting image format support for this context:                              #
##   gif89a is supported                                                       #
##   jpeg is supported                                                         #
##   png is supported                                                          #
## Getting information via Simple API methods only:                            #
##   Device Height = 800                                                       #
## Getting information via implementation specific constructor:                #
##   Device Height = 800                                                       #
## Getting information via PropertyRef:                                        #
##   Browser height = 788                                                      #
## Getting information via custom convenience methods:                         #
##   Device Height = 800                                                       #
##   Device Width = 0                                                          #
##   Image formats = gif89a,jpeg,png                                           #
##                                                                             #
################################################################################