Fixed issues with filtering by commonName, name, etc where there are multiple elements. CP NEEDED

(:~
: This is the Care Services Discovery base XQuery module
: @version 1.0
: @see http://ihe.net
:
:)
module namespace csd = "urn:ihe:iti:csd:2013" ;
declare default element  namespace   "urn:ihe:iti:csd:2013";

(:~
 : this function accepts a list of items to filter by address
 :
 : @param $items - a list of items to filter by their <address/> child elements
 : @param $components - a list of address component values.  Each item should have an @component attribute indicating the component type. The text content is the component value.
 : @return all items in $items which have address/addressLine which matches exactly (case insensitive) on each of the given components.
 : @since 1.0
 :
:)
declare function csd:filter_by_address($items as item()*,$components as item()*) as item()*
{
    if (count($components) = 0
       or not ($components[1]/@component)
       or not ($components[1]/text())
    )
    then  $items
    else
           let $comp := fn:upper-case($components[1]/@component)
           let $val := fn:upper-case($components[1]/text())
           return csd:filter_by_address(
              $items[address/addressLine[fn:upper-case(@component) = $comp and fn:upper-case(text()) = $val]],
              fn:subsequence($components,2)
          )
};

(:~
 : this function accepts a list of items to filter by type
 :
 : @param $items - a list of items to filter by their <codedType/> child elements
 : @param $codedtype - a coded type, if specified, to filter the $items list by type.  A @code attribute, if present, results in selecting those $items with matching codedType/@code (case-insensitive) exactly.  Text content, if present,  results in selecting the $items whose codedType/text() contains that value (case-insensitive) with the given @codingSchema (case-insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_coded_type($items as item()*, $codedtype as item()) as item()*
{
     if ($codedtype/@code and $codedtype/@codingSchema)
     then
        let $code := fn:upper-case($codedtype/@code)
	    let $cSchema := $codedtype/@codingSchema
        return $items[codedType[
                @code = @code
 	            and
                @codingSchema = $cSchema
                ]
            ]
     else $items
};

(:~
 : this function accepts a list of items to filter by their primary name
 :
 : @param $items - a list of items to filter by their <primaryName/> child elements
 : @param $primaryName - a name, if specified, to filter the $items list by their <primaryName/> child elements.  The text content of $primaryName, if present, results in selecting those $items containing that content. Case-insenisitive.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_primary_name($items as item()*,$primaryName as item()) as item()*
{

      if (not($primaryName = ''))
      then
          let $u_primaryName := fn:upper-case($primaryName)
          return $items[contains(fn:upper-case(./primaryName) , $u_primaryName)]
      else $items
};

(:~
 : this function accepts a list of items to filter by their primary name or other name
 :
 : @param $items - a list of items to filter by their <primaryName/> and <otherName/> child elements
 : @param $name - a name, if specified, to filter the $items list by either their <primaryName/> or <otherName/> child elements .  The text content of $name, if present, results in selecting those $items containing that content. Case-insenisitive.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_name($items as item()*,$name as item()) as item()*
{
  if (not($name = ''))
    then
    let $u_name:= fn:upper-case($name)
    for $item in $items
      let $matches0:=
        for $name in $item/otherName
	return if (contains(upper-case($name),$u_name)) then ($name) else ()
      let $matches1 := ($matches0, $item[contains(upper-case(primaryName),$u_name)])
      where  count($matches1) > 0
     return $item
  else $items
};

(:~
 : this function accepts a list of items to filter by their primary id
 :
 : @param $items - a list of items to filter by their primary id
 : @param $id - a uniqueID, if present with an non-empty @oid attribute then it is used to filter the $items list by their @oid attributes by performing an exact match of the @oid $id.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_primary_id($items as item()*,$id as item()) as item()*
{
       if ($id/@oid)
       then $items[@oid =$id/@oid]
       else $items
};

(:~
 : this function accepts a list of items to filter by their  by their <otherId/> child elements
 :
 : @param $items - a list of items to filter by their id
 : @param $id - an otherIDI, if specified, to filter the $items list by their @code and @assigningAuthorityName attributes any child <otherID> elements by performing an exact, case-insensitive match of the @code and @assigningAuthorityName attributes of $id.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_other_id($items as item()*,$id as item()) as item()*
{
       if ($id/@assigningAuthorityName)
       then
           let $aaName := fn:upper-case($id/@assigningAuthorityName	)
           let $code := fn:upper-case($id/@code)
           return $items[
                          otherID[
                            fn:upper-case(@assigningAuthorityName)=$aaName
                            and
 			   fn:upper-case(@code)=$code
                         ]
                        ]
        else $items
};

(:~
 : this function accepts a list of items to filter by their common name
 :
 : @param $items - a list of items to filter by their common name
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/commonName child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_common_name($items as item()*, $name as item()) as item()*
{
       if (not($name = ''))
	 then
	 let $u_name:= fn:upper-case($name)
	 for $item in $items
	 let $matches:=
	   for $name in $item/demographic/name/commonName
	     return if (contains(upper-case($name),$u_name)) then ($name) else ()
	 where count($matches) > 0
	 return $item
       else $items
};

(:~
 : this function accepts a list of items to filter by their surname
 :
 : @param $items - a list of items to filter by their surname
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/surname child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_surname($items as item()*, $name as item()) as item()*
{
       if (not($name = ''))
       then
	 let $u_name:= fn:upper-case($name)
	 for $item in $items
	 let $matches:=
	   for $name in $item/demographic/name/surname
	     return if (contains(upper-case($name),$u_name)) then ($name) else ()
	 where count($matches) > 0
	 return $item
       else $items
};

(:~
 : this function accepts a list of items to filter by the start of their surname
 :
 : @param $items - a list of items to filter by their surname
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/surname child-element whose text content starts with the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_surname_starts_with($items as item()*, $name as item()) as item()*
{
       if (not($name = ''))
       then
	 let $u_name:= fn:upper-case($name)
	 for $item in $items
	 let $matches:=
	   for $name in $item/demographic/name/surname
	     return if (starts-with(upper-case($name),$u_name)) then ($name) else ()
	 where count($matches) > 0
	 return $item
       else $items
};

(:~
 : this function accepts a list of items to filter by their forename
 :
 : @param $items - a list of items to filter by their forename
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/forename child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_forename($items as item()*, $name as item()) as item()*
{
       if (not($name = ''))
       then
	 let $u_name:= fn:upper-case($name)
	 for $item in $items
	 let $matches:=
	   for $name in $item/demographic/name/forename
	     return if (contains(upper-case($name),$u_name)) then ($name) else ()
	 where count($matches) > 0
	 return $item
       else $items
};

(:~
 : this function accepts a list of items to filter by the start of their forename
 :
 : @param $items - a list of items to filter by their forename
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/forename child-element whose text content starts with the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_forename_starts_with($items as item()*, $name as item()) as item()*
{
       if (not($name =''))
       then
	 let $u_name:= fn:upper-case($name)
	 for $item in $items
	 let $matches:=
	   for $name in $item/demographic/name/forename
	     return if (starts-with(upper-case($name),$u_name)) then ($name) else ()
	 where count($matches) > 0
	 return $item
       else $items
};

(:~
 : this function accepts a list of items to filter by their record details
 :
 : @param $items - a list of items to filter by their record details
 : @param $record - a csd:record, if specified, to filter the $items list selecting those whose child record/@status matches $record/@status exactly (case insensitive) if $record/@status is presnet non-empty and record/@updated is at least $record/@updated if the later is present and non-empty
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_record($items as item()*, $record as item()) as item()*
{
    let $items1:=
        if (not($record/@status) )
        then $items
        else
             let $u_status:= fn:upper-case($record/@status)
             return $items[fn:upper-case(record/@status) = $u_status]
    return
        if (not($record/@updated) )
        then $items1
        else $items1[record/@updated >= $record/@updated ]

};

(:~
 : this function accepts a list of items to limit to a subset
 :
 : @param $items - a list of items to limit
 : @param $start - a start index for limiting the item list.  If not specified then defaults to 1
 : @param $max - a maximum number of results to return.  If negattive or not specified returns all restults.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:limit_items($items as item()*, $start as item(),$max as item()) as item()*
{
        if (not(fn:number($start)) or xs:integer($start) < 1)
        then if (not(fn:number($max)) or xs:integer($max) < 0)
            then $items
            else $items[position() <= xs:integer($max)]
        else if (fn:number($max) and xs:integer($max) >= 0)
        then $items[position() >= xs:integer($start) and position() < (xs:integer($start) + xs:integer(max))]
        else $items[position() >= xs:integer($start)]

 };

(:~
 : this function accepts a list of items to filter against a list of organizations
 :
 : @param $items - a list of items to filter by their record details
 : @param $orgs - a list of organizations that to filter $items against.  A member of $items is kept if there is at least one member of $orgs to which it is associated to
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_organizations($items as item()*,$orgs as item()*) as item()*
{
    if (count($orgs) = 0 )
    then  ()
    else
    	$items[organizations/organization/@oid = $orgs[1]/@oid ]
        union
        csd:filter_by_organizations($items, fn:subsequence($orgs,2))
};

(:~
 : this function accepts a list of items to filter against a list of facilities
 :
 : @param $items - a list of items to filter by their record details
 : @param $orgs - a list of facilities that to filter $items against.  A member of $items is kept if there is at least one member of $facs to which it is associated to
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_facilities($items as item()*,$facs as item()*) as item()*
{
    if (count($facs) = 0 )
    then  ()
    else
    	$items[facilities/facility/@oid  = $facs[1]/@oid]
        union
        csd:filter_by_facilities($items, fn:subsequence($facs,2))
};

(:~
 : this function accepts a list of organizations and augments it to invclude all (grand-)*child organizations that are present within the given organization directory
 : @param $orgs - a list of organizations
 : @param $orgdir - the organization directory we are looking within to find (grand-)*child organizations
 : @return all organizations of $orgdir which are (grand-)*child organization of the list or given organizations $orgs. includes $orgs.
:)
declare function csd:join_child_organizations($orgs as item()*,$orgdir as item()) as item()*
{
     if (count($orgs) = 0)
     then ()
     else
        csd:get_child_organizations($orgs[1],$orgdir)
        union
        csd:join_child_organizations(fn:subsequence($orgs,2),$orgdir)
};

(:~
 : this function returns a list of all (grand-)*child organizations of a given organization with the given organization directory
 : @param $org - an organization
 : @param $orgdir - the organization directory we are looking within to find (grand-)*child organizations
 : @return all organizations of $orgdir which are (grand-)*child organization of the list or given organization $org. includes $org.
:)
declare function csd:get_child_organizations($org as item(),$orgdir as item()) as item()*
{
    if (not($org))
    then ()
    else
       let $root := fn:upper-case($org/@root)
       let $extension := fn:upper-case($org/@extension)
       let $child_orgs := $orgdir/organization[
                               fn:upper-case(parent/@root)=$root
                               and fn:upper-case(parent/@extension)=$extension
                               ]
       return ($org,csd:join_child_organizations($child_orgs,$orgdir))
};

(:~
 : this function returns a list of all (grand-)*parent organizations of a given organization with the given organization directory
 : @param $org - an organization
 : @param $orgdir - the organization directory we are looking within to find (grand-)*parent organizations
 : @return all organizations of $orgdir which are (grand-)*parent organization of the list or given organization $org. includes $org.
:)
declare function csd:get_parent_organizations($org as item(),$orgdir as item()) as item()*
{
    if (not($org/parent/@root))
    then $org
    else
       let $root := fn:upper-case($org/parent/@root)
       let $extension := fn:upper-case($org/parent/@extension)
       return (
                $org ,
               csd:get_parent_organizations(
                    $orgdir/organization[
                        fn:upper-case(@root)=$root and fn:upper-case(@extension)=$extension
                        ],
                    $orgdir
                    )
               )
};

(:~
 : this function accepts a list of organizations and augments it to invclude all (grand-)*parent organizations that are present within the given organization directory
 : @param $orgs - a list of organizations
 : @param $orgdir - the organization directory we are looking within to find (grand-)*parent organizations
 : @return all organizations of $orgdir which are (grand-)*parent organization of the list or given organizations $orgs. includes $orgs.
:)
declare function csd:join_parent_organizations($orgs as item()*,$orgdir as item()) as item()*
{
     if (count($orgs) = 0)
     then ()
     else
        csd:get_parent_organizations($orgs[1],$orgdir)
        union
        csd:join_parent_organizations(fn:subsequence($orgs,2),$orgdir)
};

(:~
: This is the Care Services Discovery base XQuery module
: @version 1.0
: @see http://ihe.net
:
:)
module namespace csd = "urn:ihe:iti:csd:2013" ;
declare default element  namespace   "urn:ihe:iti:csd:2013";

(:~
 : this function accepts a list of items to filter by address
 :
 : @param $items - a list of items to filter by their <address/> child elements
 : @param $components - a list of address component values.  Each item should have an @component attribute indicating the component type. The text content is the component value.
 : @return all items in $items which have address/addressLine which matches exactly (case insensitive) on each of the given components.
 : @since 1.0
 :
:)
declare function csd:filter_by_address($items as item()*,$components as item()*) as item()*
{
    if (count($components) = 0
       or not ($components[1]/@component)
       or not ($components[1]/text())
    )
    then  $items
    else
           let $comp := fn:upper-case($components[1]/@component)
           let $val := fn:upper-case($components[1]/text())
           return csd:filter_by_address(
              $items[address/addressLine[fn:upper-case(@component) = $comp and fn:upper-case(text()) = $val]],
              fn:subsequence($components,2)
          )
};

(:~
 : this function accepts a list of items to filter by type
 :
 : @param $items - a list of items to filter by their <codedType/> child elements
 : @param $codedtype - a coded type, if specified, to filter the $items list by type.  A @code attribute, if present, results in selecting those $items with matching codedType/@code (case-insensitive) exactly.  Text content, if present,  results in selecting the $items whose codedType/text() contains that value (case-insensitive) with the given @codingSchema (case-insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_coded_type($items as item()*, $codedtype as item()) as item()*
{
     if ($codedtype/@code and $codedtype/@codingSchema)
     then
        let $code := fn:upper-case($codedtype/@code)
	    let $cSchema := $codedtype/@codingSchema
        return $items[codedType[
                @code = @code
 	            and
                @codingSchema = $cSchema
                ]
            ]
     else $items
};

(:~
 : this function accepts a list of items to filter by their primary name
 :
 : @param $items - a list of items to filter by their <primaryName/> child elements
 : @param $primaryName - a name, if specified, to filter the $items list by their <primaryName/> child elements.  The text content of $primaryName, if present, results in selecting those $items containing that content. Case-insenisitive.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_primary_name($items as item()*,$primaryName as item()) as item()*
{

      if ($primaryName)
      then
          let $u_primaryName := fn:upper-case($primaryName)
          return $items[contains(fn:upper-case(./primaryName) , $u_primaryName)]
      else $items
};

(:~
 : this function accepts a list of items to filter by their primary name or other name
 :
 : @param $items - a list of items to filter by their <primaryName/> and <otherName/> child elements
 : @param $name - a name, if specified, to filter the $items list by either their <primaryName/> or <otherName/> child elements .  The text content of $name, if present, results in selecting those $items containing that content. Case-insenisitive.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_name($items as item()*,$name as item()) as item()*
{
       if ($name)
       then
          let $u_name := fn:upper-case($name)
          return $items[
                   contains(fn:upper-case(./primaryName) , $u_name)
                   or ./otherName[contains(fn:upper-case(.),$u_name)]
                   ]
       else $items
};

(:~
 : this function accepts a list of items to filter by their primary id
 :
 : @param $items - a list of items to filter by their primary id
 : @param $id - a uniqueID, if present with an non-empty @oid attribute then it is used to filter the $items list by their @oid attributes by performing an exact match of the @oid $id.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_primary_id($items as item()*,$id as item()) as item()*
{
       if ($id/@oid)
       then $items[@oid =$id/@oid]
       else $items
};

(:~
 : this function accepts a list of items to filter by their  by their <otherId/> child elements
 :
 : @param $items - a list of items to filter by their id
 : @param $id - an otherIDI, if specified, to filter the $items list by their @code and @assigningAuthorityName attributes any child <otherID> elements by performing an exact, case-insensitive match of the @code and @assigningAuthorityName attributes of $id.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_other_id($items as item()*,$id as item()) as item()*
{
       if ($id/@assigningAuthorityName)
       then
           let $aaName := fn:upper-case($id/@assigningAuthorityName	)
           let $code := fn:upper-case($id/@code)
           return $items[
                          otherID[
                            fn:upper-case(@assigningAuthorityName)=$aaName
                            and
 			   fn:upper-case(@code)=$code
                         ]
                        ]
        else $items
};

(:~
 : this function accepts a list of items to filter by their common name
 :
 : @param $items - a list of items to filter by their common name
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/commonName child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_common_name($items as item()*, $name as item()) as item()*
{
       if ($name)
       then
           let $u_name:= fn:upper-case($name)
           return $items[contains(fn:upper-case(demographic/name/commonName) ,$u_name)]
       else $items
};

(:~
 : this function accepts a list of items to filter by their surname
 :
 : @param $items - a list of items to filter by their surname
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/surname child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_surname($items as item()*, $name as item()) as item()*
{
       if ($name)
       then
           let $u_name:= fn:upper-case($name)
           return $items[contains(fn:upper-case(demographic/name/surname) ,$u_name)]
       else $items
};

(:~
 : this function accepts a list of items to filter by the start of their surname
 :
 : @param $items - a list of items to filter by their surname
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/surname child-element whose text content starts with the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_surname_starts_with($items as item()*, $name as item()) as item()*
{
       if ($name)
       then
           let $u_name:= fn:upper-case($name)
           return $items[starts-with(fn:upper-case(demographic/name/surname) ,$u_name)]
       else $items
};

(:~
 : this function accepts a list of items to filter by their forename
 :
 : @param $items - a list of items to filter by their forename
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/forename child-element whose text content contains the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_forename($items as item()*, $name as item()) as item()*
{
       if ($name)
       then
           let $u_name:= fn:upper-case($name)
           return $items[contains(fn:upper-case(demographic/name/forename) ,$u_name)]
       else $items
};

(:~
 : this function accepts a list of items to filter by the start of their forename
 :
 : @param $items - a list of items to filter by their forename
 : @param $name - an xs:string, if specified, to filter the $items list selecting those whose child demographic/name/forename child-element whose text content starts with the text content of $name (case insensitive)
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_forename_starts_with($items as item()*, $name as item()) as item()*
{
       if ($name)
       then
           let $u_name:= fn:upper-case($name)
           return $items[starts-with(fn:upper-case(demographic/name/forename) ,$u_name)]
       else $items
};

(:~
 : this function accepts a list of items to filter by their record details
 :
 : @param $items - a list of items to filter by their record details
 : @param $record - a csd:record, if specified, to filter the $items list selecting those whose child record/@status matches $record/@status exactly (case insensitive) if $record/@status is presnet non-empty and record/@updated is at least $record/@updated if the later is present and non-empty
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_record($items as item()*, $record as item()) as item()*
{
    let $items1:=
        if (not($record/@status) )
        then $items
        else
             let $u_status:= fn:upper-case($record/@status)
             return $items[fn:upper-case(record/@status) = $u_status]
    return
        if (not($record/@updated) )
        then $items1
        else $items1[record/@updated >= $record/@updated ]

};

(:~
 : this function accepts a list of items to limit to a subset
 :
 : @param $items - a list of items to limit
 : @param $start - a start index for limiting the item list.  If not specified then defaults to 1
 : @param $max - a maximum number of results to return.  If negattive or not specified returns all restults.
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:limit_items($items as item()*, $start as item(),$max as item()) as item()*
{
        if (not(fn:number($start)) or xs:integer($start) < 1)
        then if (not(fn:number($max)) or xs:integer($max) < 0)
            then $items
            else $items[position() <= xs:integer($max)]
        else if (fn:number($max) and xs:integer($max) >= 0)
        then $items[position() >= xs:integer($start) and position() < (xs:integer($start) + xs:integer(max))]
        else $items[position() >= xs:integer($start)]

 };

(:~
 : this function accepts a list of items to filter against a list of organizations
 :
 : @param $items - a list of items to filter by their record details
 : @param $orgs - a list of organizations that to filter $items against.  A member of $items is kept if there is at least one member of $orgs to which it is associated to
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_organizations($items as item()*,$orgs as item()*) as item()*
{
    if (count($orgs) = 0 )
    then  ()
    else
    	$items[organizations/organization/@oid = $orgs[1]/@oid ]
        union
        csd:filter_by_organizations($items, fn:subsequence($orgs,2))
};

(:~
 : this function accepts a list of items to filter against a list of facilities
 :
 : @param $items - a list of items to filter by their record details
 : @param $orgs - a list of facilities that to filter $items against.  A member of $items is kept if there is at least one member of $facs to which it is associated to
 : @return all items in $items which match as above
 : @since 1.0
 :
:)
declare function csd:filter_by_facilities($items as item()*,$facs as item()*) as item()*
{
    if (count($facs) = 0 )
    then  ()
    else
    	$items[facilities/facility/@oid  = $facs[1]/@oid]
        union
        csd:filter_by_facilities($items, fn:subsequence($facs,2))
};

(:~
 : this function accepts a list of organizations and augments it to invclude all (grand-)*child organizations that are present within the given organization directory
 : @param $orgs - a list of organizations
 : @param $orgdir - the organization directory we are looking within to find (grand-)*child organizations
 : @return all organizations of $orgdir which are (grand-)*child organization of the list or given organizations $orgs. includes $orgs.
:)
declare function csd:join_child_organizations($orgs as item()*,$orgdir as item()) as item()*
{
     if (count($orgs) = 0)
     then ()
     else
        csd:get_child_organizations($orgs[1],$orgdir)
        union
        csd:join_child_organizations(fn:subsequence($orgs,2),$orgdir)
};

(:~
 : this function returns a list of all (grand-)*child organizations of a given organization with the given organization directory
 : @param $org - an organization
 : @param $orgdir - the organization directory we are looking within to find (grand-)*child organizations
 : @return all organizations of $orgdir which are (grand-)*child organization of the list or given organization $org. includes $org.
:)
declare function csd:get_child_organizations($org as item(),$orgdir as item()) as item()*
{
    if (not($org))
    then ()
    else
       let $root := fn:upper-case($org/@root)
       let $extension := fn:upper-case($org/@extension)
       let $child_orgs := $orgdir/organization[
                               fn:upper-case(parent/@root)=$root
                               and fn:upper-case(parent/@extension)=$extension
                               ]
       return ($org,csd:join_child_organizations($child_orgs,$orgdir))
};

(:~
 : this function returns a list of all (grand-)*parent organizations of a given organization with the given organization directory
 : @param $org - an organization
 : @param $orgdir - the organization directory we are looking within to find (grand-)*parent organizations
 : @return all organizations of $orgdir which are (grand-)*parent organization of the list or given organization $org. includes $org.
:)
declare function csd:get_parent_organizations($org as item(),$orgdir as item()) as item()*
{
    if (not($org/parent/@root))
    then $org
    else
       let $root := fn:upper-case($org/parent/@root)
       let $extension := fn:upper-case($org/parent/@extension)
       return (
                $org ,
               csd:get_parent_organizations(
                    $orgdir/organization[
                        fn:upper-case(@root)=$root and fn:upper-case(@extension)=$extension
                        ],
                    $orgdir
                    )
               )
};

(:~
 : this function accepts a list of organizations and augments it to invclude all (grand-)*parent organizations that are present within the given organization directory
 : @param $orgs - a list of organizations
 : @param $orgdir - the organization directory we are looking within to find (grand-)*parent organizations
 : @return all organizations of $orgdir which are (grand-)*parent organization of the list or given organizations $orgs. includes $orgs.
:)
declare function csd:join_parent_organizations($orgs as item()*,$orgdir as item()) as item()*
{
     if (count($orgs) = 0)
     then ()
     else
        csd:get_parent_organizations($orgs[1],$orgdir)
        union
        csd:join_parent_organizations(fn:subsequence($orgs,2),$orgdir)
};


*	Improved gui session gate. Users and groups are managed just now.

git-svn-id: b46a086423077f2361295c5ec15b0f9cbe8e278c@1844 b091869f-ef14-0410-ae3d-fae7310851ef

xquery version "1.0" encoding "UTF-8";

(:~
 : This module sends information about current user session.
 : @author José María Fernández
 :)

import module namespace request="http://exist-db.org/xquery/request";
import module namespace response="http://exist-db.org/xquery/response";
import module namespace session="http://exist-db.org/xquery/session";
import module namespace util="http://exist-db.org/xquery/util";
import module namespace xmldb="http://exist-db.org/xquery/xmldb";

import module namespace mgmt = 'http://www.cnio.es/scombio/xcesc/1.0/xquery/systemManagement' at 'xmldb:exist:///db/XCESC-logic/systemManagement.xqm';
import module namespace login = 'http://www.cnio.es/scombio/xcesc/1.0/xquery/login' at 'xmldb:exist:///db/XCESC-logic/gui-login.xqm';

declare variable $TEMPLATE_POSTFIX as xs:string := '-template';
declare variable $SERVERS_PATH_KEY as xs:string := '/servers';
declare variable $SERVERS_TEMPLATE_PATH_KEY as xs:string := concat($SERVERS_PATH_KEY,$TEMPLATE_POSTFIX);
declare variable $USERS_PATH_KEY as xs:string := '/users';
declare variable $USERS_TEMPLATE_PATH_KEY as xs:string := concat($USERS_PATH_KEY,$TEMPLATE_POSTFIX);

let $path := request:get-path-info()
let $user-id := session:get-attribute($login:XCESC_USER_ID_KEY)
let $res := if($path eq $SERVERS_TEMPLATE_PATH_KEY) then (
	200
	,
	mgmt:servers-template()
) else if($path eq $USERS_TEMPLATE_PATH_KEY) then (
	200
	,
	mgmt:user-template()
) else if(session:exists() and exists($user-id)) then (
	if($path eq '') then (
		let $logo := util:log-app('error','xcesc.cron',string-join((xmldb:get-current-user(),$user-id,session:get-attribute('user'),session:get-attribute('password'),session:get-attribute-names()),' '))
		return (
			200
			,
			mgmt:getRestrictedInfoFromId($user-id)
		)
	) else if($path eq $USERS_PATH_KEY) then (
		200
		,
		mgmt:getRestrictedUserListFromId($user-id)
	) else if($path eq $SERVERS_PATH_KEY) then (
		200
		,
		mgmt:getRestrictedServerListFromId($user-id)
	) else (
		400
	)
) else if($path eq $USERS_PATH_KEY) then (
	200
	,
	mgmt:empty-user-template()
) else if($path eq $SERVERS_PATH_KEY) then (
	200
	,
	mgmt:empty-servers-template()
) else (
	401
)
return (
	response:set-header('Cache-Control','no-store, must-revalidate')
	,
	if(count($res) > 1) then (
		$res[2]
	) else (
		util:declare-option('exist:serialize',"method=text media-type=text/plain process-xsl-pi=no"),
		response:set-status-code($res[1])
	)
)

xquery version "1.0" encoding "UTF-8";

(:~
 : This module sends information about current user session.
 : @author José María Fernández
 :)

import module namespace request="http://exist-db.org/xquery/request";
import module namespace response="http://exist-db.org/xquery/response";
import module namespace session="http://exist-db.org/xquery/session";
import module namespace util="http://exist-db.org/xquery/util";
import module namespace xmldb="http://exist-db.org/xquery/xmldb";

import module namespace mgmt = 'http://www.cnio.es/scombio/xcesc/1.0/xquery/systemManagement' at 'xmldb:exist:///db/XCESC-logic/systemManagement.xqm';
import module namespace login = 'http://www.cnio.es/scombio/xcesc/1.0/xquery/login' at 'xmldb:exist:///db/XCESC-logic/gui-login.xqm';

let $path := request:get-path-info()
let $user-id := session:get-attribute($login:XCESC_USER_ID_KEY)
let $res := if(session:exists() and exists($user-id)) then (
	if($path eq '') then (
		let $logo := util:log-app('error','xcesc.cron',string-join((xmldb:get-current-user(),$user-id,session:get-attribute('user'),session:get-attribute('password'),session:get-attribute-names()),' '))
		return (
			200
			,
			mgmt:getRestrictedInfoFromId($user-id)
		)
	) else if($path eq '/users') then (
		200
		,
		mgmt:getRestrictedUserListFromId($user-id)
	) else (
		400
	)
) else if($path eq '/users') then (
	200
	,
	mgmt:user-template()
) else (
	401
)
return (
	response:set-header('Cache-Control','no-store, must-revalidate')
	,
	if(count($res) > 1) then (
		$res[2]
	) else (
		util:declare-option('exist:serialize',"method=text media-type=text/plain process-xsl-pi=no"),
		response:set-status-code($res[1])
	)
)


[ignore] Disable the user management panel in the admin web app: modifying the admin user may lead to serious problem ("dba" group membership is removed). Needs to be checked.

svn path=/trunk/eXist/; revision=16211

xquery version "3.0";
(:
    $Id$

    Main module of the database administration interface.
:)

declare namespace admin = "http://exist-db.org/xquery/admin-interface";

declare namespace request = "http://exist-db.org/xquery/request";
declare namespace session = "http://exist-db.org/xquery/session";
declare namespace util = "http://exist-db.org/xquery/util";
declare namespace xdb = "http://exist-db.org/xquery/xmldb";

import module namespace status = "http://exist-db.org/xquery/admin-interface/status" at "status.xqm";
import module namespace browse = "http://exist-db.org/xquery/admin-interface/browse" at "browse.xqm";
import module namespace users = "http://exist-db.org/xquery/admin-interface/users" at "users.xqm";
import module namespace xqueries = "http://exist-db.org/xquery/admin-interface/xqueries" at "xqueries.xqm";
import module namespace shut = "http://exist-db.org/xquery/admin-interface/shutdown" at "shutdown.xqm";
import module namespace setup = "http://exist-db.org/xquery/admin-interface/setup" at "setup.xqm";
import module namespace rev="http://exist-db.org/xquery/admin-interface/revisions" at "versions.xqm";
import module namespace backup="http://exist-db.org/xquery/admin-interface/backup" at "backup.xqm";
import module namespace prof="http://exist-db.org/xquery/profiling" at "trace.xqm";
import module namespace grammar="http://exist-db.org/xquery/admin-interface/grammar" at "grammar.xqm";
import module namespace install="http://exist-db.org/xquery/install-tools" at "install.xqm";
import module namespace fundocs="http://exist-db.org/xquery/admin/fundocs" at "fundocs.xqm";
import module namespace repomanager="http://exist-db.org/xquery/admin-interface/repo" at "repo.xqm";
import module namespace indexes="http://exist-db.org/xquery/admin-interface/indexes" at "indexes.xqm";

declare option exist:serialize "method=xhtml media-type=text/html";

(:
    Display the version, SVN revision and user info in the top right corner
:)
declare function admin:info-header() as element()
{

Version: { util:system-property( "product-version" ) }

SVN Revision: { util:system-property( "svn-revision" ) }

Build: {util:system-property("product-build")}

User: { xdb:get-current-user() }

};

(:
    Display the menu on left side
:)
declare function admin:menu-panel() as element()
{
    let $link := session:encode-url(request:get-uri())
    return

Select a Page

Browse

Collections

Indexes

Install

Documentation

betterFORM Examples

System

Shutdown

Status

Tooling

Backups

Package Repository

Query Profiling

View

Grammar cache

Running Jobs

Home

Logout

};

(:
    Select the page to show. Every page is defined in its own module
:)
declare function admin:panel() as element()
{
    let $panel := request:get-parameter("panel", "status")[1] return
        switch ($panel)
            case "browse"    return  browse:main()
            (:case "users"     return  users:main():)
            case "xqueries"  return  xqueries:main()
            case "shutdown"  return  shut:main()
            case "setup"     return  setup:main()
            case "fundocs"   return  fundocs:main()
    		case "repo"      return  repomanager:main()
    		case "revisions" return  rev:main()
    		case "backup"    return  backup:main()
    	    case "trace"     return  prof:main()
            case "grammar"   return  grammar:main()
            case "install"   return  install:main()
            case "indexes"   return  indexes:main()
            default          return  status:main()
};

declare function admin:panel-header() {
    let $panel := request:get-parameter("panel", "status")[1]
    return
        if ($panel[1] eq "install") then
            install:header()
        else()
};

(:~
    Display the login form.
:)
declare function admin:display-login-form() as element()
{

Login

This is a protected resource. Only registered database users can log
        in. If you have not set up any users, login as "admin" and leave the
        password field empty. Note that the "guest" user is not permitted access.

        <form action="{session:encode-url(request:get-uri())}" method="post">

                    Please Login

                    Username:
                    <input name="user" type="text" size="20"/>

                    Password:
                    <input name="pass" type="password" size="20"/>

                    <input type="submit" value="Login"/>

            {
                for $param in request:get-parameter-names()
                return
                    if ( $param = ("user","pass") ) then
                        ()
                    else
                        <input type="hidden" name="{$param}" value="{request:get-parameter($param, ())}"/>

            }
        </form>

};

(: main entry point :)
let $userParam := request:get-parameter("user", ())
let $passwdParam := request:get-parameter("pass", ())
let $isLoggedIn :=  if(xdb:get-current-user() eq "guest") then
    (
        (: is this a login attempt? :)
        if($userParam and not(empty($passwdParam)))then
        (
            if($userParam = ("", "guest") )then
            (
                (: prevent the guest user from accessing the admin webapp :)
                false()
            )
            else
            (
                (: try and log the user in :)
                xdb:login( "/db", $userParam, $passwdParam, true() )
            )
        )
        else
        (
            (: prevent the guest user from accessing the admin webapp :)
            false()
        )
    )
    else
    (
        (: if we are already logged in, are we logging out - i.e. set permissions back to guest :)
        if(request:get-parameter("logout",()))then
        (
        	let $null  := xdb:login("/db", "guest", "guest")
            let $inval := session:invalidate()

            return false()
        )
        else
        (
             (: we are already logged in and we are not the guest user :)
            true()
        )
    )
return (
    <?css-conversion no?>,

            <title>eXist Database Administration</title>
            <link type="text/css" href="admin.css" rel="stylesheet"/>
			<link type="text/css" href="styles/prettify.css" rel="stylesheet"/>
            <link rel="shortcut icon" href="../resources/exist_icon_16x16.ico"/>
			<link rel="icon" href="../resources/exist_icon_16x16.png" type="image/png"/>

			{ admin:panel-header() }

                { admin:info-header() }

                    {
                        if($isLoggedIn) then
                            admin:menu-panel()
                        else
                        ()
                    }

                        Logged in as: {xdb:get-current-user()}

                {
                    if($isLoggedIn)then
                    (
                        admin:panel()
                    )
                    else
                    (
                        admin:display-login-form()
                    )
                }

)

xquery version "3.0";
(:
    $Id$

    Main module of the database administration interface.
:)

declare namespace admin = "http://exist-db.org/xquery/admin-interface";

declare namespace request = "http://exist-db.org/xquery/request";
declare namespace session = "http://exist-db.org/xquery/session";
declare namespace util = "http://exist-db.org/xquery/util";
declare namespace xdb = "http://exist-db.org/xquery/xmldb";

import module namespace status = "http://exist-db.org/xquery/admin-interface/status" at "status.xqm";
import module namespace browse = "http://exist-db.org/xquery/admin-interface/browse" at "browse.xqm";
import module namespace users = "http://exist-db.org/xquery/admin-interface/users" at "users.xqm";
import module namespace xqueries = "http://exist-db.org/xquery/admin-interface/xqueries" at "xqueries.xqm";
import module namespace shut = "http://exist-db.org/xquery/admin-interface/shutdown" at "shutdown.xqm";
import module namespace setup = "http://exist-db.org/xquery/admin-interface/setup" at "setup.xqm";
import module namespace rev="http://exist-db.org/xquery/admin-interface/revisions" at "versions.xqm";
import module namespace backup="http://exist-db.org/xquery/admin-interface/backup" at "backup.xqm";
import module namespace prof="http://exist-db.org/xquery/profiling" at "trace.xqm";
import module namespace grammar="http://exist-db.org/xquery/admin-interface/grammar" at "grammar.xqm";
import module namespace install="http://exist-db.org/xquery/install-tools" at "install.xqm";
import module namespace fundocs="http://exist-db.org/xquery/admin/fundocs" at "fundocs.xqm";
import module namespace repomanager="http://exist-db.org/xquery/admin-interface/repo" at "repo.xqm";
import module namespace indexes="http://exist-db.org/xquery/admin-interface/indexes" at "indexes.xqm";

declare option exist:serialize "method=xhtml media-type=text/html";

(:
    Display the version, SVN revision and user info in the top right corner
:)
declare function admin:info-header() as element()
{

Version: { util:system-property( "product-version" ) }

SVN Revision: { util:system-property( "svn-revision" ) }

Build: {util:system-property("product-build")}

User: { xdb:get-current-user() }

};

(:
    Display the menu on left side
:)
declare function admin:menu-panel() as element()
{
    let $link := session:encode-url(request:get-uri())
    return

Select a Page

Browse

Collections

Indexes

Install

Documentation

betterFORM Examples

System

Shutdown

Status

Tooling

Backups

Package Repository

Query Profiling

User Management

View

Grammar cache

Running Jobs

Home

Logout

};

(:
    Select the page to show. Every page is defined in its own module
:)
declare function admin:panel() as element()
{
    let $panel := request:get-parameter("panel", "status")[1] return
        switch ($panel)
            case "browse"    return  browse:main()
            case "users"     return  users:main()
            case "xqueries"  return  xqueries:main()
            case "shutdown"  return  shut:main()
            case "setup"     return  setup:main()
            case "fundocs"   return  fundocs:main()
    		case "repo"      return  repomanager:main()
    		case "revisions" return  rev:main()
    		case "backup"    return  backup:main()
    	    case "trace"     return  prof:main()
            case "grammar"   return  grammar:main()
            case "install"   return  install:main()
            case "indexes"   return  indexes:main()
            default          return  status:main()
};

declare function admin:panel-header() {
    let $panel := request:get-parameter("panel", "status")[1]
    return
        if ($panel[1] eq "install") then
            install:header()
        else()
};

(:~
    Display the login form.
:)
declare function admin:display-login-form() as element()
{

Login

This is a protected resource. Only registered database users can log
        in. If you have not set up any users, login as "admin" and leave the
        password field empty. Note that the "guest" user is not permitted access.

        <form action="{session:encode-url(request:get-uri())}" method="post">

                    Please Login

                    Username:
                    <input name="user" type="text" size="20"/>

                    Password:
                    <input name="pass" type="password" size="20"/>

                    <input type="submit" value="Login"/>

            {
                for $param in request:get-parameter-names()
                return
                    if ( $param = ("user","pass") ) then
                        ()
                    else
                        <input type="hidden" name="{$param}" value="{request:get-parameter($param, ())}"/>

            }
        </form>

};

(: main entry point :)
let $userParam := request:get-parameter("user", ())
let $passwdParam := request:get-parameter("pass", ())
let $isLoggedIn :=  if(xdb:get-current-user() eq "guest") then
    (
        (: is this a login attempt? :)
        if($userParam and not(empty($passwdParam)))then
        (
            if($userParam = ("", "guest") )then
            (
                (: prevent the guest user from accessing the admin webapp :)
                false()
            )
            else
            (
                (: try and log the user in :)
                xdb:login( "/db", $userParam, $passwdParam, true() )
            )
        )
        else
        (
            (: prevent the guest user from accessing the admin webapp :)
            false()
        )
    )
    else
    (
        (: if we are already logged in, are we logging out - i.e. set permissions back to guest :)
        if(request:get-parameter("logout",()))then
        (
        	let $null  := xdb:login("/db", "guest", "guest")
            let $inval := session:invalidate()

            return false()
        )
        else
        (
             (: we are already logged in and we are not the guest user :)
            true()
        )
    )
return (
    <?css-conversion no?>,

            <title>eXist Database Administration</title>
            <link type="text/css" href="admin.css" rel="stylesheet"/>
			<link type="text/css" href="styles/prettify.css" rel="stylesheet"/>
            <link rel="shortcut icon" href="../resources/exist_icon_16x16.ico"/>
			<link rel="icon" href="../resources/exist_icon_16x16.png" type="image/png"/>

			{ admin:panel-header() }

                { admin:info-header() }

                    {
                        if($isLoggedIn) then
                            admin:menu-panel()
                        else
                        ()
                    }

                        Logged in as: {xdb:get-current-user()}

                {
                    if($isLoggedIn)then
                    (
                        admin:panel()
                    )
                    else
                    (
                        admin:display-login-form()
                    )
                }

)


Updated XQTS application's docs.

Updated XQTS application's docs.

svn path=/trunk/eXist/; revision=6835

xquery version "1.0";
(: $Id$ :)

import module namespace util="http://exist-db.org/xquery/util";
import module namespace request="http://exist-db.org/xquery/request";
import module namespace xdb="http://exist-db.org/xquery/xmldb";
declare namespace system="http://exist-db.org/xquery/system";

declare namespace xqts="http://exist-db.org/xquery/xqts";
declare namespace catalog="http://www.w3.org/2005/02/query-test-XQTSCatalog";

declare variable $xqts:XML_HIGHLIGHT_STYLE := "/db/XQTS/xml-highlight.xsl";
declare variable $xqts:CONFIG := xqts:initialize();
declare variable $xqts:XQTS_HOME := $xqts:CONFIG/basedir/text();

declare option exist:output-size-limit "-1";

declare function xqts:initialize() as element()? {
    let $collection := xdb:create-collection("/db", "XQTS")
    let $config := doc("/db/XQTS/config.xml")/config
    return
        if (exists($config)) then
            $config
        else
            let $home := system:get-exist-home()
            let $pathSep := util:system-property("file.separator")
    		let $dir :=
				if (doc-available(concat("file:///", system:get-module-load-path(), "/config.xml")))
				then
					system:get-module-load-path()
        		else if(ends-with($home, "WEB-INF")) then
        	    	concat(substring-before($home, "WEB-INF"), "xqts")
        		else
               		concat($home, $pathSep, "webapp", $pathSep, "xqts")
            let $stored := xdb:store-files-from-pattern("/db/XQTS", $dir, "*.xml", "text/xml")
            return
                doc("/db/XQTS/config.xml")/config
};

(:~ The required stylesheets were not found in the db. Try to import them. :)
declare function xqts:import-stylesheet() as xs:string* {
    let $home := system:get-exist-home()
    let $pathSep := util:system-property("file.separator")
    let $dir :=
			if (doc-available(concat("file:///", system:get-module-load-path(), "config.xml")))
			then
				concat(system:get-module-load-path())
        	else if(ends-with($home, "WEB-INF")) then
        	    concat(substring-before($home, "WEB-INF"), "xqts")
        	else
               concat($home, $pathSep, "webapp", $pathSep, "xqts")
    let $col := xdb:create-collection("/db", "XQTS")
    return
        concat("Imported: ", xdb:store-files-from-pattern($col, $dir, "*.xsl", "text/xml"))
};

(:~ Check for stylesheets required for the application. Try to import them if they could not be found. :)
declare function xqts:check-paths() as xs:string* {
    if (not(doc-available($xqts:XML_HIGHLIGHT_STYLE))) then
        let $dummy := xqts:import-stylesheet()
        return
            if (not(doc-available($xqts:XML_HIGHLIGHT_STYLE))) then
                concat($xqts:XML_HIGHLIGHT_STYLE, " not found! Please store this file into ",
                    "the database collection or the application will not work properly.")
            else ()
    else ()
};

declare function xqts:path-to-uri($path as xs:string) as xs:string {
        if (starts-with($path, "/")) then
            concat("file://", $path)
        else
            concat("file:///", $path)
};

declare function xqts:get-query($case as element(catalog:test-case)) {
   let $query-name := $case//catalog:query/@name
   let $path := concat(xqts:path-to-uri($xqts:XQTS_HOME), "Queries/XQuery/",
       $case/@FilePath, $query-name, ".xq")
   let $xq-string := util:file-read($path)
   return $xq-string
   (: let $tokenized := tokenize($xq-string, "\n")
   for $token in $tokenized return
       ($token,
) :)
};

declare function xqts:display-page() as element() {
    util:declare-option("exist:serialize", "media-type=text/html method=xhtml"),

            <title>{string(/catalog:test-suite/catalog:test-suite-info/catalog:title)} - Test Reports</title>
            <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
            <link type="text/css" href="styles/report.css" rel="stylesheet"/>
			<link type="text/css" href="styles/SyntaxHighlighter.css" rel="stylesheet"/>

xquery version "1.0";
(: $Id$ :)

import module namespace util="http://exist-db.org/xquery/util";
import module namespace request="http://exist-db.org/xquery/request";
import module namespace xdb="http://exist-db.org/xquery/xmldb";
declare namespace system="http://exist-db.org/xquery/system";

declare namespace xqts="http://exist-db.org/xquery/xqts";
declare namespace catalog="http://www.w3.org/2005/02/query-test-XQTSCatalog";

declare variable $xqts:XML_HIGHLIGHT_STYLE := "/db/XQTS/xml-highlight.xsl";
declare variable $xqts:CONFIG := xqts:initialize();
declare variable $xqts:XQTS_HOME := $xqts:CONFIG/basedir/text();

declare option exist:output-size-limit "-1";

declare function xqts:initialize() as element() {
    let $collection := xdb:create-collection("/db", "XQTS")
    let $config := doc("/db/XQTS/config.xml")/config
    return
        if (exists($config)) then
            $config
        else
            let $home := system:get-exist-home()
            let $pathSep := util:system-property("file.separator")
    		let $dir :=
				if (doc-available(concat("file:///", system:get-module-load-path(), "/config.xml")))
				then
					system:get-module-load-path()
        		else if(ends-with($home, "WEB-INF")) then
        	    	concat(substring-before($home, "WEB-INF"), "xqts")
        		else
               		concat($home, $pathSep, "webapp", $pathSep, "xqts")
            let $stored := xdb:store-files-from-pattern("/db/XQTS", $dir, "*.xml", "text/xml")
            return
                doc("/db/XQTS/config.xml")/config
};

(:~ The required stylesheets were not found in the db. Try to import them. :)
declare function xqts:import-stylesheet() as xs:string* {
    let $home := system:get-exist-home()
    let $pathSep := util:system-property("file.separator")
    let $dir :=
			if (doc-available(concat("file:///", system:get-module-load-path(), "config.xml")))
			then
				concat(system:get-module-load-path())
        	else if(ends-with($home, "WEB-INF")) then
        	    concat(substring-before($home, "WEB-INF"), "xqts")
        	else
               concat($home, $pathSep, "webapp", $pathSep, "xqts")
    let $col := xdb:create-collection("/db", "XQTS")
    return
        concat("Imported: ", xdb:store-files-from-pattern($col, $dir, "*.xsl", "text/xml"))
};

(:~ Check for stylesheets required for the application. Try to import them if they could not be found. :)
declare function xqts:check-paths() as xs:string* {
    if (not(doc-available($xqts:XML_HIGHLIGHT_STYLE))) then
        let $dummy := xqts:import-stylesheet()
        return
            if (not(doc-available($xqts:XML_HIGHLIGHT_STYLE))) then
                concat($xqts:XML_HIGHLIGHT_STYLE, " not found! Please store this file into ",
                    "the database collection or the application will not work properly.")
            else ()
    else ()
};

declare function xqts:path-to-uri($path as xs:string) as xs:string {
        if (starts-with($path, "/")) then
            concat("file://", $path)
        else
            concat("file:///", $path)
};

declare function xqts:get-query($case as element(catalog:test-case)) {
   let $query-name := $case//catalog:query/@name
   let $path := concat(xqts:path-to-uri($xqts:XQTS_HOME), "Queries/XQuery/",
       $case/@FilePath, $query-name, ".xq")
   let $xq-string := util:file-read($path)
   return $xq-string
   (: let $tokenized := tokenize($xq-string, "\n")
   for $token in $tokenized return
       ($token,
) :)
};

declare function xqts:display-page() as element() {
    util:declare-option("exist:serialize", "media-type=text/html method=xhtml"),

            <title>{string(/catalog:test-suite/catalog:test-suite-info/catalog:title)} - Test Reports</title>
            <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
            <link type="text/css" href="styles/report.css" rel="stylesheet"/>
			<link type="text/css" href="styles/SyntaxHighlighter.css" rel="stylesheet"/>


[ignore] xproc tweaks

[ignore] xproc tweaks

svn path=/trunk/eXist/; revision=12264

xquery version "1.0" encoding "UTF-8";

declare namespace t="http://xproc.org/ns/testsuite";
declare namespace c="http://www.w3.org/ns/xproc-step";

(:NOTE - requires file module to be enabled :)
declare namespace file="http://exist-db.org/xquery/file";

import module namespace xproc = "http://xproc.net/xproc";

declare option exist:serialize "method=html media-type=text/html omit-xml-declaration=yes indent=yes";

let $not :=  request:get-parameter("not", ())
let $type :=  request:get-parameter("type", ())
let $dir := concat('/Users/jimfuller/Source/Thirdparty/eXist/extensions/xprocxq/main/test/tests.xproc.org/',$type)
let $file :=  request:get-parameter("file", ())
let $files := file:directory-list($dir,$file)
let $result := for $file in $files/*:file[not(contains(@name,$not))]

let $path := concat('file://',$dir,$file/@name)

let $stdin1 :=doc($path)/t:test

let $stdin :=  if ($stdin1//t:pipeline/@href) then

<t:test xmlns:t="http://xproc.org/ns/testsuite"
        xmlns:p="http://www.w3.org/ns/xproc"
        xmlns:c="http://www.w3.org/ns/xproc-step"
        xmlns:err="http://www.w3.org/ns/xproc-error">

{$stdin1//t:input[not(@href)]}
{let $a := $stdin1//t:input[@href]
return
for $input in $a
return
		<t:input port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:input>
}
<t:pipeline>
{let $doc := doc(concat('file://',$dir,$stdin1//t:pipeline/@href))
return
    $doc
}
</t:pipeline>

{$stdin1//t:output[not(@href)]}
{let $a := $stdin1//t:output[@href]
return
for $input in $a
return
		<t:output port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:output>
}
</t:test>
               else

<t:test xmlns:t="http://xproc.org/ns/testsuite"
        xmlns:p="http://www.w3.org/ns/xproc"
        xmlns:c="http://www.w3.org/ns/xproc-step"
        xmlns:err="http://www.w3.org/ns/xproc-error">

{$stdin1//t:input[not(@href)]}
{let $a := $stdin1//t:input[@href]
return
for $input in $a
return
		<t:input port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:input>
}

{$stdin1//t:pipeline}

{$stdin1//t:output[not(@href)]}
{let $a := $stdin1//t:output[@href]
return
for $input in $a
return
		<t:output port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:output>
}
</t:test>

let $pipeline := if (count($stdin//t:input) = 0) then
        doc('/db/xproc/unit-test/test-runner2.xml')
    else if ( count($stdin//t:input) = 1) then
        doc('/db/xproc/unit-test/test-runner.xml')
    else
        doc('/db/xproc/unit-test/test-runner1.xml')

let $runtime-debug := request:get-parameter("dbg", ())
    return
    <test file="{$file/@name}">
        {
        if (contains($path,request:get-parameter("debug", ()))) then
           xproc:run($pipeline,$stdin,$runtime-debug)
        else
            util:catch('*', xproc:run($pipeline,$stdin,$runtime-debug), 'test crashed')
         }
     </test>
return
let $final-result := <result pass="{count($result//c:result[.= 'true'])}" nopass="{count($result//c:result[.= 'false'])}" total="{count($result//test)}">
    {$result}
</result>
let	$params :=
		<parameters>
			<param name="now" value="{current-time()}"/>
		</parameters>
return
    if (request:get-parameter("format", ()) eq 'html') then
      transform:transform(document{$final-result}, xs:anyURI("xmldb:exist:///db/xproc/unit-test/test-result.xsl"), ())
    else if (request:get-parameter("format", ()) eq 'w3c') then
      transform:transform(document{$final-result}, xs:anyURI("xmldb:exist:///db/xproc/unit-test/w3c-test-result.xsl"), ())
    else
        $final-result

xquery version "1.0" encoding "UTF-8";

declare namespace t="http://xproc.org/ns/testsuite";
declare namespace c="http://www.w3.org/ns/xproc-step";

(:NOTE - requires file module to be enabled :)
declare namespace file="http://exist-db.org/xquery/file";

import module namespace const = "http://xproc.net/xproc/const";
import module namespace xproc = "http://xproc.net/xproc";
import module namespace u = "http://xproc.net/xproc/util";
import module namespace naming = "http://xproc.net/xproc/naming";

declare option exist:serialize "method=html media-type=text/html omit-xml-declaration=yes indent=yes";

let $not :=  request:get-parameter("not", ())
let $type :=  request:get-parameter("type", ())
let $dir := concat('/Users/jimfuller/Source/Thirdparty/eXist/extensions/xprocxq/main/test/tests.xproc.org/',$type)
let $file :=  request:get-parameter("file", ())
let $files := file:directory-list($dir,$file)
let $result := for $file in $files/*:file[not(contains(@name,$not))]

let $path := concat('file://',$dir,$file/@name)

let $stdin1 :=doc($path)/t:test

let $stdin :=  if ($stdin1//t:pipeline/@href) then

<t:test xmlns:t="http://xproc.org/ns/testsuite"
        xmlns:p="http://www.w3.org/ns/xproc"
        xmlns:c="http://www.w3.org/ns/xproc-step"
        xmlns:err="http://www.w3.org/ns/xproc-error">

{$stdin1//t:input[not(@href)]}
{let $a := $stdin1//t:input[@href]
return
for $input in $a
return
		<t:input port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:input>
}
<t:pipeline>
{let $doc := doc(concat('file://',$dir,$stdin1//t:pipeline/@href))
return
    $doc
}
</t:pipeline>

{$stdin1//t:output[not(@href)]}
{let $a := $stdin1//t:output[@href]
return
for $input in $a
return
		<t:output port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:output>
}
</t:test>
               else

<t:test xmlns:t="http://xproc.org/ns/testsuite"
        xmlns:p="http://www.w3.org/ns/xproc"
        xmlns:c="http://www.w3.org/ns/xproc-step"
        xmlns:err="http://www.w3.org/ns/xproc-error">

{$stdin1//t:input[not(@href)]}
{let $a := $stdin1//t:input[@href]
return
for $input in $a
return
		<t:input port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:input>
}

{$stdin1//t:pipeline}

{$stdin1//t:output[not(@href)]}
{let $a := $stdin1//t:output[@href]
return
for $input in $a
return
		<t:output port="{$input/@port}">
			{let $doc := doc(concat('file://',$dir,$input/@href))
			return
			    $doc}
		</t:output>
}
</t:test>

let $pipeline := if (count($stdin//t:input) = 0) then
        doc('/db/xproc/unit-test/test-runner2.xml')
    else if ( count($stdin//t:input) = 1) then
        doc('/db/xproc/unit-test/test-runner.xml')
    else
        doc('/db/xproc/unit-test/test-runner1.xml')

let $runtime-debug := request:get-parameter("dbg", ())
    return
    <test file="{$file/@name}">
        {
        if (contains($path,request:get-parameter("debug", ()))) then
           xproc:run($pipeline,$stdin,$runtime-debug)
        else
            util:catch('*', xproc:run($pipeline,$stdin,$runtime-debug), 'test crashed')
         }
     </test>
return
let $final-result := <result pass="{count($result//c:result[.= 'true'])}" nopass="{count($result//c:result[.= 'false'])}" total="{count($result//test)}">
    {$result}
</result>
let	$params :=
		<parameters>
			<param name="now" value="{current-time()}"/>
		</parameters>
return
    if (request:get-parameter("format", ()) eq 'html') then
      transform:transform(document{$final-result}, xs:anyURI("xmldb:exist:///db/xproc/unit-test/test-result.xsl"), ())
    else if (request:get-parameter("format", ()) eq 'w3c') then
      transform:transform(document{$final-result}, xs:anyURI("xmldb:exist:///db/xproc/unit-test/w3c-test-result.xsl"), ())
    else
        $final-result


Used variable to try to accelerate 'nondeterministic' execution of filesystem requests. Introduced papertitles top level list. Added function for inspecting what type a note is from its location in the document. Rationalised the links generator to rely exclusively on hash. Introduced prioritisation for note types.

module namespace notes="http://cefn.com/readinglog/notes";

import module namespace template="http://cefn.com/readinglog/template" at "/home/cefn/Documents/highwire/participatory firmware design/readinglog/scripts/server/xquery/lib/template.xq";

declare namespace ann = "http://www.zorba-xquery.com/annotations";

declare default element namespace "http://www.w3.org/1999/xhtml";

declare variable $notes:allnotes := template:loadhtml("public/notes/");
declare variable $notes:papertitles := $notes:allnotes//h1;

declare variable $notes:authors := "Authors";
declare variable $notes:concepts := "Concepts";
declare variable $notes:headings := (
	$notes:authors,
	$notes:concepts,
	'Methodology',
	'Field of Study',
	'Quotations',
	'References'
);

(: Introspects the noted document's unique id from any note element :)
declare function notes:paperhash($node){
	root($node)//comment()[contains(string(.),"UNIQUE HASH")]/replace(string(.)," UNIQUE HASH ([\w]+) ", "$1")
};

declare %ann:nondeterministic function notes:notesoftype($type){
	$notes:allnotes//*[not(self::h2)][preceding::h2[1]//text()[contains(.,$type)]]
};

declare function notes:type($node){
	if($node/ancestor::h1) then
			'Titles'
		else
			normalize-space(string-join($node/(preceding::h2[1])/text(),""))
};

declare function notes:followingheader($nodes,$title){
	$nodes//*[preceding-sibling::h2[1][text()[normalize-space(.)=$title]]]
};

declare function notes:paperlinks($hash as xs:string){

		[notes pdf load]

};

(: Indicates a priority order for individual note types e.g. in search results:)
declare function notes:typepriority($type){
	let $priorities := ('Titles','Notes','Concepts','Quotations'),
		$matches := index-of(reverse($priorities),$type)
	return if(count($matches)) then $matches[1] else 0
};

module namespace notes="http://cefn.com/readinglog/notes";

import module namespace template="http://cefn.com/readinglog/template" at "/home/cefn/Documents/highwire/participatory firmware design/readinglog/scripts/server/xquery/lib/template.xq";

declare namespace ann = "http://www.zorba-xquery.com/annotations";

declare default element namespace "http://www.w3.org/1999/xhtml";

declare variable $notes:authors := "Authors";
declare variable $notes:concepts := "Concepts";
declare variable $notes:headings := (
	$notes:authors,
	$notes:concepts,
	'Methodology',
	'Field of Study',
	'Quotations',
	'References'
);

declare %ann:nondeterministic function notes:allnotes(){
	template:loadhtml("public/notes/")
};

(: Introspects the noted document's unique id from any note element :)
declare function notes:paperhash($node){
	root($node)//comment()[contains(string(.),"UNIQUE HASH")]/replace(string(.)," UNIQUE HASH ([\w]+) ", "$1")
};

declare %ann:nondeterministic function notes:notesoftype($type){
	notes:allnotes()//*[not(self::h2)][preceding::h2[1]//text()[contains(.,$type)]]
};

declare function notes:followingheader($nodes,$title){
	$nodes//*[preceding-sibling::h2[1][text()[normalize-space(.)=$title]]]
};

declare function notes:paperlinks($node){
	let $hash := notes:paperhash($node)
	return

		[
			notes
			pdf
			load
		]

};


[bugfix] KWIC module should respect text nodes and not treat them as strings; Previously serializing introduced erroneous whitespace text nodes, i.e. text { ("a", "b") } gives  "a b", whereas we should have had text { "a" }, text { "b" } which gives "ab".

(:~
    KWIC module: formats query results to display keywords in context (KWIC). A configurable
    amount of text is displayed to the left and right of a matching keyword (or phrase).

    The module works with all indexes that support match highlighting (matches are tagged
    with an <exist:match> element or exist:matches attribute). This includes the old
    full text index, the new Lucene-based full text index, as well as the NGram index.

    The kwic:summarize() function represents the main entry point into the module.
    To have more control over the text extraction context, you can also call
    kwic:get-summary() instead. For example, the following snippet will only print the
    first match within a given set of context nodes ($ancestor):

    let $matches := kwic:get-matches($hit)

    for $ancestor in $matches/ancestor::para | $matches/ancestor::title | $matches/ancestor::td

    return

        kwic:get-summary($ancestor, ($ancestor//exist:match, $ancestor//*[@exist:matches])[1], $config)

    The configuration element used by some functions has the following structure:

    <config
        width="character width"
        table="yes|no"
        link="URL to which the match is linked"/>
:)
xquery version "3.0";

module namespace kwic = "http://exist-db.org/xquery/kwic";

import module namespace util = "http://exist-db.org/xquery/util";

declare namespace exist = "http://exist.sourceforge.net/NS/exist";

declare variable $kwic:MODE_BEFORE := "before";
declare variable $kwic:MODE_AFTER := "after";

declare %private variable $kwic:CHARS_SUMMARY := 120;
declare %private variable $kwic:CHARS_KWIC := 40;

(:~
	Like fn:substring, but takes a node argument. If the node is an element,
	a new element is created with the same node-name as the old one and the
	shortened text content.
:)
declare
    %private
function kwic:substring($node as item(), $start as xs:integer, $count as xs:integer) as item()? {
	let $str := substring($node, $start, $count)
	return
		if ($node instance of element()) then
			element { node-name($node) } { $str }
		else
			text { $str }
};

declare
    %private
function kwic:display-text($text as text()?) as node()? {
    if ($text/parent::exist:match) then
    	{$text}
    else
        $text
};

declare
    %private
function kwic:callback($callback as (function(text(), xs:string) as text()?)?, $node as text(), $mode as xs:string) as text()? {
    if (exists($callback)) then
        $callback($node, $mode)
    else
        $node
};

(:~
	Generate the left-hand context of the match. Returns a sequence of nodes
	and strings, whose total string length is less than or equal to $max characters.

	Note: this function calls itself recursively until $nodes is empty or
	the returned sequence has the desired total string length.
:)
declare
    %private
function kwic:truncate-previous($root as node(), $node as node()?, $truncated as item()*,
	   $max as xs:integer, $chars as xs:integer, $callback as (function(text(), xs:string) as text()?)?) {
	if ($node) then
		let $next := $node/preceding::text()[1] intersect $root//text()
		return
			if (empty($next)) then
				$truncated
			else if ($chars + string-length($next) gt $max) then
			    let $str := kwic:callback($callback, $next, $kwic:MODE_BEFORE)
			    return
    			    if (exists($str)) then
        				let $remaining := $max - $chars
        				return (
        				    text { "..." },
        				    kwic:substring($str, string-length($str) - $remaining + 1, $remaining),
        				    $truncated
        			    )
        			else
        			    kwic:truncate-previous($root, $next, $truncated, $max, $chars, $callback)
			else
				kwic:truncate-previous($root, $next,
				    (kwic:callback($callback, $next, $kwic:MODE_BEFORE), $truncated),
					$max, $chars + string-length($next), $callback)
	else
		$truncated
};

(:~
	Generate the right-hand context of the match. Returns a sequence of nodes
	and strings, whose total string length is less than or equal to $max characters.

	Note: this function calls itself recursively until $nodes is empty or
	the returned sequence has the desired total string length.
:)
declare
    %private
function kwic:truncate-following($root as node(), $node as node()?, $truncated as item()*,
	$max as xs:integer, $chars as xs:integer, $callback as (function(text(), xs:string) as text()?)?) {
	if ($node) then
		let $next := $node/following::text()[1] intersect $root//text()
		return
			if (empty($next)) then
				$truncated
			else if ($chars + string-length($next) gt $max) then
			    let $str := kwic:callback($callback, $next, $kwic:MODE_AFTER)
			    return
    			    if (exists($str)) then
        				let $remaining := $max - $chars
        				return (
        				    $truncated, kwic:substring($next, 1, $remaining), text { "..." }
        			    )
        			else
        			    kwic:truncate-following($root, $next, $truncated, $max, $chars, $callback)
			else
				kwic:truncate-following($root, $next,
				    ($truncated, kwic:callback($callback, $next, $kwic:MODE_AFTER)),
					$max, $chars + string-length($next), $callback)
	else
		$truncated
};

(:~
	Computes the total string length of the nodes in the argument sequence
:)
declare
    %private
function kwic:string-length($nodes as item()*) as xs:integer {
	if (exists($nodes)) then
		sum($nodes ! string-length(.))
	else
		0
};

declare function kwic:get-summary($root as node(), $node as element(),
	$config as element(config)?) as element() {
	kwic:get-summary($root, $node, $config, ())
};

(:~
	Print a summary of the match in $node. Output a predefined amount of text to
	the left and the right of the match.

	@param $root root element which should be used as context for the match. It defines the
	    boundaries for the text extraction. Text will be taken from this context.
	@param $node the exist:match element or the element with @exist:macthes attribute to process.
	@param $config configuration element which determines the behaviour of the function
	@param $callback (optional) reference to a callback function which will be called
	once for every text node before it is appended to the displayed text. The function
	should accept 2 parameters: 1) a single text node, 2) a string indicating the
	current direction in which text is appended, i.e. $kwic:MODE_BEFORE or $kwic:MODE_AFTER.
	The function may return the empty sequence if the current node should be ignore
	(e.g. if it belongs to a "footnote" which should not be displayed). Otherwise it should
	return a single string.
:)
declare function kwic:get-summary($root as node(), $node as element(),
	$config as element(config)?,
    $callback as (function(text(), xs:string) as text()?)?
) as element() {
	let $chars := xs:integer(($config/@width, $kwic:CHARS_KWIC)[1])
	let $table := $config/@table = ('yes', 'true')
	let $prevTrunc := kwic:truncate-previous($root, $node, (), $chars, 0, $callback)
	let $remain :=
		if (not($table)) then
			$chars * 2 - kwic:string-length($prevTrunc)
		else
			$chars
	let $followingTrunc := kwic:truncate-following($root, $node, (), $remain, 0, $callback)
	return
		if (not($table)) then

				{$prevTrunc}
				{
					if ($config/@link) then
						{ $node/text() }
					else
						{ $node/text() }
				}
				{$followingTrunc}

		else

				{$prevTrunc}

				{
					if ($config/@link) then
						{$node/text()}
					else
						$node/text()
				}

				{$followingTrunc}

};

(:~
    Expand the element in $hit. Creates an in-memory copy of the element and marks
    all element matches with an exist:match tag and attribute matches with an
    exist:matches tag, which will be used by all other functions in
    this module. You need to call kwic:expand before kwic:get-summary.
    kwic:summarize will call it automatically.
:)
declare function kwic:expand($hit as element()) as element() {
    util:expand($hit, "expand-xincludes=no highlight-matches=both")
};

(:~
    Return all matches within the specified element, $hit. Matches are returned as
    exist:match elements or elements with exist:matches attribute. The returned nodes
    are part of a new document whose root element is a copy of the specified $hit element.

    @param $hit an arbitrary XML element which has been selected by one of the full text
		operations or an ngram search.
:)
declare function kwic:get-matches($hit as element()) as element()* {
    let $expanded := kwic:expand($hit)
	return ($expanded//exist:match, $expanded//*[@exist:matches])
};

declare function kwic:summarize($hit as element(), $config as element(config)?) as element()* {
    kwic:summarize($hit, $config, ())
};

(:~
	Main function of the KWIC module: takes the passed element and returns an
	XHTML fragment containing a chunk of text before and after the first full text
	match in the node.

	The optional config parameter is used to configure the behaviour of the function:

	<config width="character width" table="yes|no" link="URL to which the match is linked"/>

	By default, kwic:summarize returns an XHTML fragment with the following structure:

	<p xmlns="http://www.w3.org/1999/xhtml">
		<span class="previous">Text before match</span>
		<a href="passed URL if any" class="hi">The highlighted term</a>
		<span class="following">Text after match</span>
	</p>

	If table=yes is passed with the config element, a tr table row will be returned instead
	of a span (using the same class names).

	@param $hit an arbitrary XML element which has been selected by one of the full text
		operations or an ngram search.
	@param $config configuration element to configure the behaviour of the function
:)
declare function kwic:summarize($hit as element(), $config as element(config)?,
    $callback as (function(text(), xs:string) as text()?)?) as element()* {
    let $expanded := util:expand($hit, "expand-xincludes=no highlight-matches=both")
	for $match in ($expanded//exist:match, $expanded//*[@exist:matches])
	return
		kwic:get-summary($expanded, $match, $config, $callback)
};

(:
declare function kwic:summarize-all($hits as element()*, $config as element(config),
    $wrap as function(node(), function(node()) as element()) as element()) {
    let $hits := util:expand($hits, "expand-xincludes=no")
    for $hit in $hits
    return
        $wrap($hit, function($node) {
            for $match in $node//exist:match
            return
        		kwic:get-summary($node, $match, $config, ())
        })
};
:)

(:~
    KWIC module: formats query results to display keywords in context (KWIC). A configurable
    amount of text is displayed to the left and right of a matching keyword (or phrase).

    The module works with all indexes that support match highlighting (matches are tagged
    with an <exist:match> element or exist:matches attribute). This includes the old
    full text index, the new Lucene-based full text index, as well as the NGram index.

    The kwic:summarize() function represents the main entry point into the module.
    To have more control over the text extraction context, you can also call
    kwic:get-summary() instead. For example, the following snippet will only print the
    first match within a given set of context nodes ($ancestor):

    let $matches := kwic:get-matches($hit)

    for $ancestor in $matches/ancestor::para | $matches/ancestor::title | $matches/ancestor::td

    return

        kwic:get-summary($ancestor, ($ancestor//exist:match, $ancestor//*[@exist:matches])[1], $config)

:)
module namespace kwic="http://exist-db.org/xquery/kwic";

declare variable $kwic:CHARS_SUMMARY := 120;
declare variable $kwic:CHARS_KWIC := 40;

(:~
	Like fn:substring, but takes a node argument. If the node is an element,
	a new element is created with the same node-name as the old one and the
	shortened text content.
:)
declare function kwic:substring($node as item(), $start as xs:int, $count as xs:int) as item()? {
	let $str := substring($node, $start, $count)
	return
		if ($node instance of element()) then
			element { node-name($node) } { $str }
		else
			$str
};

declare function kwic:display-text($text as text()?) as node()? {
    if ($text/parent::exist:match) then
    	{$text}
    else
        $text
};

declare function kwic:callback($callback as function(*)?, $node as node(), $mode as xs:string) as xs:string? {
    if (exists($callback)) then
        $callback($node, $mode)
    else
        $node
};

(:~
	Generate the left-hand context of the match. Returns a sequence of nodes
	and strings, whose total string length is less than or equal to $max characters.

	Note: this function calls itself recursively until $nodes is empty or
	the returned sequence has the desired total string length.
:)
declare function kwic:truncate-previous($root as node(), $node as node()?, $truncated as item()*,
	$max as xs:int, $chars as xs:int, $callback as (function(node(), xs:string) as xs:string?)?) {
	if ($node) then
		let $next := $node/preceding::text()[1] intersect $root//text()
		return
			if (empty($next)) then
				$truncated
			else if ($chars + string-length($next) gt $max) then
			    let $str := kwic:callback($callback, $next, "before")
			    return
    			    if (exists($str)) then
        				let $remaining := $max - $chars
        				return (
        				    "...",
        				    kwic:substring($str, string-length($str) - $remaining + 1, $remaining),
        				    $truncated
        			    )
        			else
        			    kwic:truncate-previous($root, $next, $truncated, $max, $chars, $callback)
			else
				kwic:truncate-previous($root, $next,
				    (kwic:callback($callback, $next, "before"), $truncated),
					$max, $chars + string-length($next), $callback)
	else
		$truncated
};

(:~
	Generate the right-hand context of the match. Returns a sequence of nodes
	and strings, whose total string length is less than or equal to $max characters.

	Note: this function calls itself recursively until $nodes is empty or
	the returned sequence has the desired total string length.
:)
declare function kwic:truncate-following($root as node(), $node as node()?, $truncated as item()*,
	$max as xs:int, $chars as xs:int, $callback as (function(node(), xs:string) as xs:string?)?) {
	if ($node) then
		let $next := $node/following::text()[1] intersect $root//text()
		return
			if (empty($next)) then
				$truncated
			else if ($chars + string-length($next) gt $max) then
			    let $str := kwic:callback($callback, $next, "after")
			    return
    			    if (exists($str)) then
        				let $remaining := $max - $chars
        				return
        				    ($truncated, kwic:substring($next, 1, $remaining), "...")
        			else
        			    kwic:truncate-following($root, $next, $truncated, $max, $chars, $callback)
			else
				kwic:truncate-following($root, $next,
				    ($truncated, kwic:callback($callback, $next, "after")),
					$max, $chars + string-length($next), $callback)
	else
		$truncated
};

(:~
	Computes the total string length of the nodes in the argument sequence
:)
declare function kwic:string-length($nodes as item()*) as xs:integer {
	if (exists($nodes)) then
		sum(for $n in $nodes return string-length($n))
	else
		0
};

declare function kwic:get-summary($root as node(), $node as element(),
	$config as element(config)?) as element() {
	kwic:get-summary($root, $node, $config, ())
};

(:~
	Print a summary of the match in $node. Output a predefined amount of text to
	the left and the right of the match.

	@param $root root element which should be used as context for the match. It defines the
	    boundaries for the text extraction. Text will be taken from this context.
	@param $node the exist:match element or the element with @exist:macthes attribute to process.
	@param $config configuration element which determines the behaviour of the function
	@param $callback (optional) reference to a callback function which will be called
	once for every text node before it is appended to the displayed text. The function
	should accept 2 parameters: 1) a single text node, 2) a string indicating the
	current direction in which text is appended, i.e. "before" or "after". The function
	may return the empty sequence if the current node should be ignore (e.g. if it belongs
	to a "footnote" which should not be displayed). Otherwise it should return a single
	string.
:)
declare function kwic:get-summary($root as node(), $node as element(),
	$config as element(config)?,
    $callback as (function(node(), xs:string) as xs:string?)?
) as element() {
	let $chars := xs:int(($config/@width, $kwic:CHARS_KWIC)[1])
	let $table := $config/@table = ('yes', 'true')
	let $prevTrunc := kwic:truncate-previous($root, $node, (), $chars, 0, $callback)
	let $remain :=
		if (not($table)) then
			$chars * 2 - kwic:string-length($prevTrunc)
		else
			$chars
	let $followingTrunc := kwic:truncate-following($root, $node, (), $remain, 0, $callback)
	return
		if (not($table)) then

				{$prevTrunc}
				{
					if ($config/@link) then
						{ $node/text() }
					else
						{ $node/text() }
				}
				{$followingTrunc}

		else

				{$prevTrunc}

				{
					if ($config/@link) then
						{$node/text()}
					else
						$node/text()
				}

				{$followingTrunc}

};

(:~
    Expand the element in $hit. Creates an in-memory copy of the element and marks
    all element matches with an exist:match tag and attribute matches with an
    exist:matches tag, which will be used by all other functions in
    this module. You need to call kwic:expand before kwic:get-summary.
    kwic:summarize will call it automatically.
:)
declare function kwic:expand($hit as element()) as element() {
    util:expand($hit, "expand-xincludes=no highlight-matches=both")
};

(:~
    Return all matches within the specified element, $hit. Matches are returned as
    exist:match elements or elements with exist:matches attribute. The returned nodes
    are part of a new document whose root element is a copy of the specified $hit element.

    @param $hit an arbitrary XML element which has been selected by one of the full text
		operations or an ngram search.
:)
declare function kwic:get-matches($hit as element()) as element()* {
    let $expanded := kwic:expand($hit)
	return ($expanded//exist:match, $expanded//*[@exist:matches])
};

declare function kwic:summarize($hit as element(), $config as element(config)?) as element()* {
    kwic:summarize($hit, $config, ())
};

(:~
	Main function of the KWIC module: takes the passed element and returns an
	XHTML fragment containing a chunk of text before and after the first full text
	match in the node.

	The optional config parameter is used to configure the behaviour of the function:

	<config width="character width" table="yes|no" link="URL to which the match is linked"/>

	By default, kwic:summarize returns an XHTML fragment with the following structure:

	<p xmlns="http://www.w3.org/1999/xhtml">
		<span class="previous">Text before match</span>
		<a href="passed URL if any" class="hi">The highlighted term</a>
		<span class="following">Text after match</span>
	</p>

	If table=yes is passed with the config element, a tr table row will be returned instead
	of a span (using the same class names).

	@param $hit an arbitrary XML element which has been selected by one of the full text
		operations or an ngram search.
	@param $config configuration element to configure the behaviour of the function
:)
declare function kwic:summarize($hit as element(), $config as element(config)?,
    $callback as (function(node(), xs:string) as xs:string?)?) as element()* {
    let $expanded := util:expand($hit, "expand-xincludes=no highlight-matches=both")
	for $match in ($expanded//exist:match, $expanded//*[@exist:matches])
	return
		kwic:get-summary($expanded, $match, $config, $callback)
};

(:
declare function kwic:summarize-all($hits as element()*, $config as element(config),
    $wrap as function(node(), function(node()) as element()) as element()) {
    let $hits := util:expand($hits, "expand-xincludes=no")
    for $hit in $hits
    return
        $wrap($hit, function($node) {
            for $match in $node//exist:match
            return
        		kwic:get-summary($node, $match, $config, ())
        })
};
:)