TM-1.56/0000755000175000017500000000000011465717611010140 5ustar rhorhoTM-1.56/META.yml0000644000175000017500000000226711465717611011420 0ustar rhorho--- #YAML:1.0 name: TM version: 1.56 abstract: Topic Maps, Base Class author: - Robert Barta license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: BerkeleyDB: 0.26 Cache::Memcached: ~ Class::Trait: 0.22 Config::General: 2.26 IO::String: 1.08 Log::Log4perl: 0.5 LWP::Simple: 1.41 MLDBM: 2.01 MLDBM::Sync: 0.3 Parse::RecDescent: ~ Parse::Yapp::Driver: 1.05 Pod::Usage: 1.16 Regexp::Common: ~ Term::ReadLine: 1.01 Test::Deep: 0.093 Test::More: 0.47 Test::Pod: 1 Text::CSV: ~ URI: 1.35 XML::LibXML: 1.58 XML::Simple: 2.13 XML::Writer: 0.602 YAML::Syck: ~ no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 TM-1.56/maps/0000755000175000017500000000000011465717610011077 5ustar rhorhoTM-1.56/maps/foaf.atm0000644000175000017500000000106210777176260012521 0ustar rhorho[ (knows) Person : http://psi.tm.bond.edu.au/astma/1.0/#psi-left Person : http://psi.tm.bond.edu.au/astma/1.0/#psi-right ] rho is-a Person bn: Robert Barta oc (mbox): mailto:rho@devc.at oc (mbox): mailto:drrho@cpan.org oc (mbox): mailto:rho@sf.net oc (mbox): mailto:robert.barta@tuwien.ac.at oc (mbox): mailto:robert.barta@arcs.ac.at lars-garshol is-a Person knows rho bn: Lars Garshol lars-heuer is-a Person knows rho bn: Lars Heuer oc (mbox): mailto:heuer@semagia.com az is-a Person knows rho bn: Alexander Zangerl oc (mbox): mailto:az@staff.bond.edu.au TM-1.56/maps/dns.atm0000644000175000017500000003413710777176260012403 0ustar rhorho# DNS (is-subclass-of) subclass: internet-service superclass: service internet-service bn: Internet Service in: service provided by set of processes using Internet protocols in (example): e-mail in (example): WWW in (example): file-transfer in (example): newsgroup in (example): IRC (chat) dns (internet-service) bn: DNS, Domain Name Service oc: http://www.internic.net/faqs/authoritative-dns.html oc: http://www.auggy.mlnet.com/ibm/3376c45.html#namesrv oc (reference): ftp://rtfm.mit.edu/pub/usenet/news.answers/internet/tcp-ip/domains-faq/ oc (introduction): http://www.dns.net/dnsrd/docs/whatis.html oc (introduction): http://www.freesoft.org/CIE/Topics/75.htm in: is a hierarchical, tree structured system -- domain name space and IP address space in: distributed Internet directory service -- used to map between domain names and IP addresses -- mapping stored in a world-wide database -- distributed over millions of machines in: most Internet services rely on DNS to work (translates) translator : dns from : domain-name to : ip-address (translates) translator : dns to : domain-name from : ip-address (is-subclass-of) subclass: domain-name superclass: name domain-name bn: Domain Name oc: http://computer.howstuffworks.com/dns3.htm oc: http://searchwebservices.techtarget.com/sDefinition/0,,sid26_gci211988,00.html in: locates an organisation or other entity on the Internet in: domain names are for human convenience, instead of machine-readable IP-addresses in: each domain name is made up of a series of character strings (labels) separated by dots: bond.edu.au. (is-subclass-of) subclass: full-qualified-domain-name superclass: domain-name full-qualified-domain-name bn: FQDN, Fully Qualified Domain Name in: to determine a unique Internet address for any host on the Internet in (example): www.bond.edu.au. ( hostname + domain-name, incl. top-level domain) (is-subclass-of) superclass : domain-name subclass : top-level-domain (is-subclass-of) superclass : domain-name subclass : second-level-domain top-level-domain bn: Top Level Domain (TLDs) oc: http://www.icann.org/tlds/ oc: http://searchwebservices.techtarget.com/sDefinition/0,,sid26_gci213511,00.html in: identifies the most general part of the domain name in an Internet address in: TLD is either a generic top-level domain (gTLD), such as "com", or a country code top-level domain (ccTLD), such as "fr" in: within every top-level domain there is a list of second-level domains in: responsibility for operating each TLD is delegated second-level-domain bn: Second Level Domain oc: http://searchwebservices.techtarget.com/sDefinition/0,,sid26_gci213548,00.html in: second-level domain name includes the top-level domain, e.g. cnn.com. in: must be unique and registered with accredited companies in: there can be duplication across domains; e.g. howstuffworks.com and howstuffworks.org are completely different domains in: can be divided into further domain levels (is-registered-by) registrar : icann registered: top-level-domain icann (organisation) bn: ICANN oc (homepage): http://www.icann.org/ in: global, non-profit corporation, responsible for managing and coordinating DNS to ensure universal resolvability -- responsible for naming, removing and introducing top-level domain names (.com, .museum, .....) in: accredits companies to run service of allocating domain names to end customers in: coordinates root-dns-servers in (history): in earlier times IANA did registration and administration oc (article): http://www.theregister.co.uk/content/6/36226.html (coordinate) coordinator : icann activity : operation-of-root-dns-server (is-operated-by) operation : operation-of-root-dns-server operator : verisign system : root-dns-server root-dns-server (server) bn: Root DNS Server in: 13 special servers distributed around the world and coordinated by ICANN in: only handle what is in the 'root zone' . -- top-level domains --\ master list of top-level domain (TLD) names is kept on server A -- list is replicated to the others oc: http://searchnetworking.techtarget.com/sDefinition/0,,sid7_gci212922,00.html oc (homepage): http://www.root-servers.org/ oc (operational-report): http://d.root-servers.org/october21.txt oc (monitoring): http://dnsmon.ripe.net/ (is-subclass-of) subclass : generic-top-level-domain superclass : top-level-domain generic-top-level-domain bn: gTLD, generic TLD oc: http://www.icann.org/tlds/ in: best known ones are .org, .com, .net, .edu, .mil, .gov in: new generic TLDs: .info, . biz, .museum, .... in: domain names in these TLDs can only be registered through ICANN-accredited registrars (is-subclass-of) subclass : country-code-top-level-domain superclass : top-level-domain country-code-top-level-domain bn: ccTLD, country-code TLD oc: http://thewhir.com/find/domain-names/guides/cc-tld.cfm in: TLDs with two letters (such as .de, .mx, and .jp) -- established for over 240 countries and external territories -- ISO 3166 in: can provides regional-specific branding that a typical generic TLD does not in (comment): common misconception is that ccTLDs can only be assigned to Web sites physically located in the suffix country --\ some countries have specific rules for who can register domains using their suffix and for what purposes (service-is-provided-by) provider : dns-server service : dns (is-subclass-of) subclass: dns-server superclass: server dns-server bn: DNS Server oc: http://computer.howstuffworks.com/dns.htm oc (setup): http://www.linux.org/docs/ldp/howto/DNS-HOWTO.html in: accepts requests from programs or from other name servers to convert domain names into IP addresses, or back in: uses the world-wide largest and most active distributed databases in: each database contains records (A, MX, NS, SOA, CNAME, PTR) in: every name server has a list of all of the known root servers in (procedure): when request arrives it can do one of four things: answer the request with an IP address by looking in its cache --\ contact another name server (recursive) --\ return IP address from another name server to client (iterative) --\ return an error message because the requested domain name is invalid or does not exist (is-subclass-of) subclass: dns-zone superclass: namespace dns-zone bn: DNS Zone oc: http://www.menandmice.com/online_docs_and_faq/glossary/zone.htm in: all information about a domain name and names within it # is-reified-by dns-zone-transfer (is-transferred) from : primary-dns-server to : secondary-dns-server what : dns-zone # is-reified-by dns-zone-transfer (is-transferred) from : dns-server to : dns-client what : dns-zone (performs-function) performer: dns-server function : dns-zone-transfer iterative-dns-query recursive-dns-query dns-zone-transfer (information-exchange) bn: Zone Transfer oc: http://www.microsoft.com/windows2000/en/server/help/default.asp?url=/windows2000/en/server/help/sag_DNS_und_ZoneTransfers.htm in: special type of query that asks a name server for the entire contents of a zone in: "trusted" DNSs exchange complete zones, using TTL for caching (how long it is valid) in: zone transfers are usually used by secondary servers to update its own zone data from its primary server in: ISPs exchange zones (is-subclass-of) subclass: iterative-dns-query superclass: dns-query iterative-dns-query bn: Iterative DNS Query oc: http://techrepublic.com.com/5100-6262-1058014.html in: DNS server answers either directly to client or gives reference to other DNS server --\ client itself has now to query the recommanded DNS server in: references are first to servers 'higher up the DNS hierarchy' (includes root servers) -- then down the hierarchy (is-subclass-of) subclass: recursive-dns-query superclass: dns-query recursive-dns-query bn: Recursive DNS Query oc: http://techrepublic.com.com/5100-6262-1058014.html in: DNS server answers directly or may contact other DNS servers for assistance (using iterative queries) --\ then passes on the information back to the client that originated the name resolution request in: more costly for DNS server (exposes) exposer: dns-server exposed: dns-database dns-database bn: DNS Database oc: http://www.tldp.org/LDP/nag/node39.html in: large distributed database -- handling billions of requests every day through a network of millions of name servers in: different types of entries the DNS database called records (A, MX, NS, SOA, CNAME, PTR, ...) in: content is organized in zones (contains) container : dns-database content : a-record ns-record mx-record soa-record cname-record ptr-record a-record (information) bn: A-Record oc: http://www.zytrax.com/books/dns/ch8/a.html oc: http://www.jhsoft.com/help/rec_a.htm in: assigns an IP address to a given domain name -- "forward lookup" in: domain name can be mapped to more than one IP-address (load-balancing, back-up) in (example): www.bond.edu.au -> A 131.244.5.50 in (example): www.ibm.com -> A 129.42.18.99 A 129.42.19.99 A 129.42.16.99 A 129.42.17.99 mx-record (information) bn: MX record oc: http://www.jhsoft.com/help/rec_MX.htm oc: http://www.rscott.org/dns/mx.html in: identifies the mail server (mail exchanger, MX) that is responsible for handling emails (incoming SMTP) for a given domain name in: can get more than one entry -- preference numbers indicate the order in which mail servers should be used --\ if best (lowest number) preference cannot be reached, then client will try next higher number in (example): @microsoft.com -> MX 10 maila.microsoft.com. -- MX 100 mailb.microsoft.com. -- MX 10 mailc.microsoft.com. ns-record (information) bn: NS record oc: http://www.zytrax.com/books/dns/ch8/ns.html in: lists the DNS servers which hold the databases for a given zone - not the IP-address in: records list the primary and secondary servers for the zone in: only one name server is defined in the SOA record but any number of NS records may be defined in (example): bond.edu.au -> NS kirk.bond.edu.au. -- NS diablo.onthenet.com.au. -- NS minerva.its.bond.edu.au. soa-record (information) bn: SOA record oc: http://www.jhsoft.com/help/rec_SOA.htm in: SOA-record lists primary DNS server -- email address of the person responsible for the zone --\ serial number used by secondary DNS servers to check if the zone has been modified --\ details about caching used by secondary DNS servers in (example): bond.edu.au. -> SOA minerva.its.bond.edu.au. hostmaster.bond.edu.au. 2003093001 10800 1800 3600000 86400 (refers-to) referrer: soa-record referral: primary-dns-server secondary-dns-server cname-record (information) bn: CNAME record oc: http://www.jhsoft.com/help/rec_CNAME.htm in: lists canonical (real) name in: host may have more than one name -- one name for the machine itself -- other names for different services on one machine in: canonical host name is the one with an A record associated -- others are simply aliases referring to the canonical host name in: CNAMEs are useful when a service needs to be migrated from between hosts in (example): www.bond.edu.au. -> CNAME huntsman.bond.edu.au. ptr-record (information) bn: PTR record oc: http://www.jhsoft.com/help/rec_PTR.htm in: PTR-records are used to map IP addresses to domain names (reverse of forward lookup) -- "reverse look-up" in: query is done by reversing the IP-address followed by IN-ADDR.ARPA. domain in (example): 1.1.244.131.in-addr.arpa -> PTR kirk.Bond.edu.au. (has-features) object : dns-server feature : dns-caching dns-redundancy dns-redundancy bn: DNS redundancy oc: http://www.dummies.com/WileyCDA/DummiesArticle/id-1699.html in: multiple name servers exist for every zone -- so if one fails, there are others to handle the requests --\ one of the key aspects to make DNS work globally in: minimum of two DNS servers is needed for each domain for fault tolerance -- usually handled by the ISP or the customer (is-achieved-through) achievement: dns-redundancy measure : secondary-dns-server dns-caching bn: DNS Caching oc: http://www.vicomsoft.com/glossary/dnscaching.html in: once a name server resolves a request, it caches all of the IP addresses it receives --\ e.g. after a request for something.com to a root server, it memorizes the IP address for that name server handling this domain --\ dramatic speed up of overall operation -- only works if the number of changes is small compared to the number of read requests in: every information has a due date -- Time To Live (TTL) -- controls how long a server will cache a piece of information (is-achieved-through) achievement: performance measure : dns-caching (is-using-protocol) user: dns-client dns-server protocol: dns-protocol dns-protocol (protocol) bn: DNS Protocol oc: http://www.freesoft.org/CIE/Course/Section2/11.htm in: application protocol used to request resource records from name server in: normal resource records lookups are done with UDP in: zone transfers -- TCP must be used -- transfer entire content of a zone between (usually between primary and secondary DNS server) dns-client bn: DNS Client, Resolver oc: http://www.menandmice.com/online_docs_and_faq/glossary/glossarytoc.htm?resolver.htm in: software within an application that formats requests to be sent to the Domain Name Server for hostname to Internet address conversion in: user program can be: e-mail, FTP client, http-client, ... in: resolver must know the name server it should use for converting URLs to IP addresses in: nearest name server is either at ISP (for individuals) or in company (is-subclass-of) subclass: primary-dns-server superclass: dns-server primary-dns-server bn: Primary DNS Server oc: http://www.menandmice.com/online_docs_and_faq/glossary/primary.server.htm in: also called 'master' (of a zone) in: holds authoritative information about a zone -- there can only be one in: this is encoded in the SOA (start of authority) record -- hostmaster, serial number, caching information (is-subclass-of) subclass: secondary-dns-server superclass: dns-server secondary-dns-server bn: Secondary DNS Server in: keeps copies of a zone -- updated on a regular basis using zone transfer in: "slave" server #-- DNSreporter ----------------------------------- (can-be-analyzed-with) tool: dns-report object: dns-database dns-report (online-service) bn: www.DNSreport.com in: debugging and testing DNS entries oc (homepage): http://www.dnsreport.com/ #%cancel TM-1.56/maps/tutorials.atm0000644000175000017500000000141511027455002013615 0ustar rhorhoperl-tm-X bn: The Trick is to Keep Breathing (Part X) oc: http://kill.devc.at/node/188 perl-tm-IX bn: TMDBMS 4 The People (Part IX) oc: http://kill.devc.at/node/182 perl-tm-VIII bn: Persistency (Part VIII) oc: http://kill.devc.at/node/181 perl-tm-VII bn: For TMDM Acolytes (Part VII) oc: http://kill.devc.at/node/165 perl-tm-VI bn: Pah, Merging (Part VI) oc: http://kill.devc.at/node/163 perl-tm-V bn: Traits Good, Classes Bad (Part V) oc: http://kill.devc.at/node/152 perl-tm-IV bn: As Low as it Gets (Part IV) oc: http://kill.devc.at/node/145 perl-tm-III bn: As Low as it Gets (Part III) oc: http://kill.devc.at/node/143 perl-tm-II bn: As Low as it Gets (Part II) oc: http://kill.devc.at/node/142 perl-tm-I bn: As Low as it Gets (Part I) oc: http://kill.devc.at/node/139TM-1.56/examples/0000755000175000017500000000000011465717610011755 5ustar rhorhoTM-1.56/examples/01_low_level.pl0000644000175000017500000000400310777176261014605 0ustar rhorhouse TM; my $tm = new TM (); # create an empty map use Data::Dumper; #warn Dumper $tm; $tm->internalize ('pony' => \ 'http://en.wikipedia.org/wiki/Pony'); warn Dumper [ $tm->toplets (\ '+all -infrastructure') ]; my ($t) = $tm->toplets ('tm://nirvana/pony'); warn Dumper $t->[TM->INDICATORS]; my $a = Assertion->new (kind => TM->ASSOC, type => 'isa', roles => [ 'instance', 'class' ], players => [ 'sacklpicka', 'cat' ]); $tm->assert ($a); use TM::Literal; $tm->assert (Assertion->new (kind => TM->NAME, type => 'name', scope => 'en', roles => [ 'thing', 'value' ], players => [ 'sacklpicka', new TM::Literal ('Der Sacklpicka') ]), Assertion->new (kind => TM->OCC, type => 'occurrence', scope => 'us', roles => [ 'thing', 'value' ], players => [ 'sacklpicka', new TM::Literal ('http://devc.at', TM::Literal->URI) ]) ); my @cats; @cats = $tm->match_forall ( type => 'isa', roles => [ 'instance', 'class' ], players => [ undef, 'cat' ] ); @cats = $tm->match_forall (type => 'isa', class => $tm->tids ('cat')); warn Dumper \@cats; warn Dumper [ map { $tm->get_players ($_, 'instance') } @cats ]; warn Dumper [ map { $_->[0] } map { $tm->get_players ($_, 'value') } grep { $_->[TM->KIND] == TM->OCC } $tm->match_forall ('topic' => $tm->tids ('sacklpicka'), 'char' => '1') ]; warn Dumper [ map { $tm->get_x_players ($_, 'thing') } $tm->match_forall ('value' => new TM::Literal ('Der Sacklpicka'), 'char' => '1') ]; #warn Dumper $tm; warn "I knew it" if $tm->is_a ($tm->tids ('sacklpicka', 'cat')); warn "Not sure about that" unless $tm->is_subclass ($tm->tids ('cat', 'thing')); __END__ __END__ TM-1.56/examples/12_index.pl0000644000175000017500000000310011440777702013716 0ustar rhorhouse Data::Dumper; use TM::ResourceAble::MLDBM; my $tm = new TM::ResourceAble::MLDBM (file => '/tmp/somemap'); use TM::Materialized::AsTMa; my $update = new TM::Materialized::AsTMa (file => 'maps/mapreduce.atm'); $update->sync_in; warn "synced"; use TM::Literal; $update->assert ( map { Assertion->new (kind => TM->NAME, type => 'name', scope => 'us', roles => [ 'thing', 'value' ], players => [ "aaa$_", new TM::Literal ("AAA$_") ]) } (1..10000) ); warn "enriched"; $tm->clear; $tm->add ($update); warn "added"; my $c = {}; use Class::Trait; Class::Trait->apply ($tm, "TM::IndexAble"); $tm->index ({ axis => 'reify', closed => 1, detached => $c }); warn "indexed"; #warn Dumper $c; Class::Trait->apply ( $tm => 'TM::Serializable::AsTMa' ); my $content = $tm->serialize; warn "serialized"; #warn $content; __END__ Class::Trait->apply ( $tm => 'TM::Serializable::AsTMa' ); use TM::Index::Reified; warn "use"; my $idx = new TM::Index::Reified ($tm, closed => 1, loose => 1); warn "idx"; warn Dumper $tm->{rindex}; __END__ use TM::Serializable::AsTMa; use Class::Trait; Class::Trait->apply ( $tm => 'TM::Serializable::AsTMa' ); my $content; { use TM::Index::Reified; my $idx = new TM::Index::Reified ($tm); warn "attached"; #use TM::Index::Taxonomy; #my $idx = new TM::Index::Taxonomy ($tm, closed => 1); $content = $tm->serialize; warn "serialized"; $idx->detach; warn "detached"; } warn $content; __END__ use TM::Materialized::MLDBM; my $tm = new TM::Materialized::MLDBM (file => '/tmp/rumsti'); $tm->internalize ('xxx'); $tm->sync_out; TM-1.56/examples/05_traits.pl0000644000175000017500000000114410777732616014134 0ustar rhorhouse TM::Materialized::AsTMa; my $tm = new TM::Materialized::AsTMa (file => 'examples/old_testament.atm'); $tm->sync_in; Class::Trait->apply ( $tm => 'TM::Graph' ); use Data::Dumper; print Dumper $tm->clusters; my ($adam, $begets) = $tm->tids ('adam', 'begets'); warn Dumper [ $tm->frontier ([ $adam ], [ [ $begets ] ]) ]; warn Dumper [ $tm->frontier ([ $adam ], bless [ [ $begets ] ], '*') ]; my ($apple, $eats) = $tm->tids ('apple_1', 'eats'); warn Dumper [ $tm->frontier ([ $apple ], [ [ $eats ], [ bless [ [ $begets ] ], '*' ] ] ) ]; TM-1.56/examples/06_diff.pl0000644000175000017500000000115610773446214013532 0ustar rhorhomy $a1 = < $a1); $tm1->sync_in; my $tm2 = new TM::Materialized::AsTMa (inline => $a2); $tm2->sync_in; use Data::Dumper; $Data::Dumper::Indent = 1; #warn Dumper $tm2->diff ($tm1); warn Dumper $tm2->diff ($tm1, { include_changes => 1 } ); TM-1.56/examples/03_mldbm.pl0000644000175000017500000000143110777176261013714 0ustar rhorhomy ($tmp); use IO::File; use POSIX qw(tmpnam); do { $tmp = tmpnam() ; } until IO::File->new ($tmp, O_RDWR|O_CREAT|O_EXCL); END { unlink ($tmp) || warn "cannot unlink tmp file '$tmp'"; } { use TM::Materialized::MLDBM; my $tm = new TM::Materialized::MLDBM (file => $tmp); $tm->assert (Assertion->new ( type => 'isa', roles => [ 'instance', 'class' ], players => [ 'sacklpicka', 'cat' ])); $tm->sync_out; } utime time + 1, time + 1, $tmp; # lets pretend that the file has been changed { use TM::Materialized::MLDBM; my $tm = new TM::Materialized::MLDBM (file => $tmp); use Data::Dumper; warn Dumper [ $tm->tids ('cat') ]; # nothing there $tm->sync_in; warn Dumper [ $tm->instances ($tm->tids ('cat')) ]; # sacklpicka is back! } TM-1.56/examples/old_testament.atm0000644000175000017500000000070510777724127015332 0ustar rhorhoadam bn: Adam Adamovich (eats) eater: adam food: apple_1 eve bn: Eve in: the first lady (begets) parent: adam eve child: cain (begets) parent: adam eve child: abel (begets) parent: adam eve child: seth (begets) parent: adam eve child: azura #-- (begets) parent: cain child: enoch #-- (begets) parent: enoch child: irad #-- (begets) parent: irad child: mehajael #-- (begets) parent: seth child: enosh (begets) parent: seth child: noam TM-1.56/examples/04_mldbm2.pl0000644000175000017500000000125410777176261014002 0ustar rhorhomy ($tmp); use IO::File; use POSIX qw(tmpnam); do { $tmp = tmpnam() ; } until IO::File->new ($tmp, O_RDWR|O_CREAT|O_EXCL); END { unlink ($tmp) || warn "cannot unlink tmp file '$tmp'"; } use Data::Dumper; # look ma, no hands! warn "file $tmp"; unlink $tmp; { use TM::Materialized::MLDBM2; my $tm = new TM::Materialized::MLDBM2 (file => $tmp); $tm->assert (Assertion->new ( type => 'owns', roles => [ 'owner', 'object' ], players => [ 'rho', 'sacklpicka' ])); warn Dumper [ $tm->tids ('rho') ]; } sleep 3; { use TM::Materialized::MLDBM2; my $tm = new TM::Materialized::MLDBM2 (file => $tmp); warn Dumper [ $tm->tids ('rho') ]; } TM-1.56/examples/11_tmql.pl0000644000175000017500000000070211035102121013541 0ustar rhorhouse TM::Materialized::AsTMa; my $tm = new TM::Materialized::AsTMa (inline => ' sacklpicka (cat) bn: Der Sacklpicka rho (person) oc (blog): http://kill.devc.at/ (owns) owner: rho owned: sacklpicka (is-subclass-of) subclass: person superclass: mammal (is-subclass-of) subclass: cat superclass: mammal '); $tm->sync_in; use TM::QL; my $q = new TM::QL ('for $a in %_ // owns return $a'); use Data::Dumper; warn Dumper $q->eval ({ '%_' => $tm }); TM-1.56/examples/10_mldbm.t0000644000175000017500000000020611030737072013523 0ustar rhorhouse TM::Materialized::MLDBM; my $tm = new TM::Materialized::MLDBM (file => '/tmp/rumsti'); $tm->internalize ('xxx'); $tm->sync_out; TM-1.56/examples/02_astma.pl0000644000175000017500000000267610777176261013741 0ustar rhorhouse TM::Materialized::AsTMa; my $tm = new TM::Materialized::AsTMa (inline => ' sacklpicka (cat) bn: Der Sacklpicka rho (person) oc (blog): http://kill.devc.at/ (owns) owner: rho owned: sacklpicka (is-subclass-of) subclass: person superclass: mammal (is-subclass-of) subclass: cat superclass: mammal '); $tm->sync_in; use Data::Dumper; warn Dumper [ $tm->instances ($tm->tids ('cat')) ]; warn Dumper [ $tm->instances ($tm->tids ('mammal')) ]; warn Dumper [ $tm->instancesT ($tm->tids ('mammal')) ]; warn "Not sure about that" unless $tm->is_subclass ($tm->tids ('cat', 'mammal')); warn Dumper [ $tm->are_instances ($tm->tids ('cat', 'rho', 'sacklpicka', 'sacklpicka') ) ]; warn Dumper [ $tm->are_instances ($tm->tids ('mammal', 'rho', 'sacklpicka', 'sacklpicka') ) ]; #---------------------- use File::Slurp; write_file( '/tmp/something.atm', "sacklpicka (cat)\n\n" ) ; $tm = new TM::Materialized::AsTMa (file => '/tmp/something.atm'); $tm->sync_in; $tm->internalize (rho); $tm->assert (Assertion->new ( type => 'owns', roles => [ 'owner', 'object' ], players => [ 'rho', 'sacklpicka' ])); #warn Dumper $tm; $tm->sync_out; #--------------------- $tm = new TM::Materialized::AsTMa (inline => ' %version 2.0 rho isa person and has name : "Robert Barta" . rho has blog : http://kill.devc.at/ . # much more is possible here '); $tm->sync_in; #warn Dumper $tm; TM-1.56/examples/08_tmdm.pl0000644000175000017500000000221611010132761013543 0ustar rhorhouse Data::Dumper; use TM::Materialized::AsTMa; my $tm = new TM::Materialized::AsTMa (inline => ' sacklpicka (cat) bn: Der Sacklpicka bn (nickname): Sleeping Devil sin: http://kill.devc.at/system/files/aad.small.jpg rho (person) oc (blog): http://kill.devc.at/ (owns) owner: rho owned: sacklpicka ')->sync_in; use TM::DM; my $tmdm = new TM::DM (map => $tm); my $topicmap = $tmdm->topicmap; my @ts = $topicmap->topics (\ '+all -infrastructure'); warn join "," , (map { $_->id } @ts); #my $sp = $topicmap->topic ('sacklpicka'); #my $sp = $topicmap->topic ('tm://nirvana/sacklpicka'); my $sp = $topicmap->topic (\ 'http://kill.devc.at/system/files/aad.small.jpg'); warn $sp->id; foreach my $n ($sp->names) { next if $n->type->id eq 'tm://nirvana/nickname'; warn $n->value; } my $rho = $topicmap->topic ('rho'); foreach my $o ($rho->occurrences) { warn $o->value->[0]; } foreach my $r ( $rho->roles ) { warn "player: ".$r->player->id; warn " for role: ".$r->type->id; } my @as = $topicmap->associations (iplayer => 'rho'); foreach my $a (@as) { warn $a->type->id; warn $a->scope->id; warn map { $_->type->id } $a->roles; } __END__ TM-1.56/examples/09_opera.pl0000644000175000017500000000073111013530413013710 0ustar rhorhouse File::Slurp; use TM; my $tm = new TM; use TM::Serializable::XTM; TM::Serializable::XTM::deserialize ($tm, join "", read_file ("maps/opera.xtm")); __END__ use Time::HiRes qw(gettimeofday tv_interval); use TM::Materialized::XTM; my $t0 = [gettimeofday]; my $tm = new TM::Materialized::XTM (file => "maps/opera.xtm")->sync_in; # NOTE: I do not bundle the opera.xtm because of its licencing restrictions warn tv_interval ( $t0 ); use Data::Dumper; #warn Dumper $tm; TM-1.56/MANIFEST0000644000175000017500000000510611465717611011273 0ustar rhorhoChanges Makefile.PL MANIFEST README TODO META.yml maps/dns.atm maps/foaf.atm maps/tutorials.atm yapp/astma-fact.yp yapp/astma2-fact.yp yapp/YappTemplate.pm t/log.conf t/00pods.t t/00utils.t t/010infrastructure.t t/011manipulate.t t/012analysis.t t/013index.t t/015indexable.t t/014insane.t t/021ctmdeserialize.t t/031synchronize.t t/032serialize.t t/03resource.t t/041astmafact.t t/042merge.t t/043diff.t t/044merge2.t t/045astma2fact.t t/046astma1serial.t t/050astma.t t/051mldbm.t t/052mldbm2.t t/054ltm.t t/055jtm.t t/056bdb.t t/057memcached.t t/061xtmserialize.t t/061xtmdeserialize.t t/062xtmserialize.t t/062xtmdeserialize.t t/063xtm.t t/064csv.t t/072bulk.t t/091taufilter.t t/092taufederate.t t/095tau.t t/096taumapsphere.t t/100mapsphere.t t/101mapsphere.t t/102mapsphere.t t/103objectable.t t/13tmdm.t schemas/xtm20.dtd schemas/xtm10.dtd schemas/xtm11.dtd lib/TM/Analysis.pm lib/TM/AsTMa/Fact2.pm lib/TM/AsTMa/Fact.pm lib/TM/Axes.pm lib/TM/Coverage.pm lib/TM/Bulk.pm lib/TM/DM.pm lib/TM/Graph.pm lib/TM/Index.pm lib/TM/Index/Characteristics.pm lib/TM/Index/Match.pm lib/TM/Index/Reified.pm lib/TM/Index/Taxonomy.pm lib/TM/IndexAble.pm lib/TM/Literal.pm lib/TM/LTM/Parser.pm lib/TM/LTM/CParser.pm lib/TM/CTM/Parser.pm lib/TM/CTM/CParser.pm lib/TM/MapSphere.pm lib/TM/Materialized/AsTMa.pm lib/TM/Materialized/LTM.pm lib/TM/Materialized/CTM.pm lib/TM/Materialized/MLDBM2.pm lib/TM/Materialized/MLDBM.pm lib/TM/Materialized/Null.pm lib/TM/Materialized/Stream.pm lib/TM/Materialized/XTM.pm lib/TM/Materialized/JTM.pm lib/TM.pm lib/TM/Overview.pm lib/TM/ObjectAble.pm lib/TM/FAQ.pm lib/TM/PSI.pm lib/TM/ResourceAble.pm lib/TM/ResourceAble/MLDBM.pm lib/TM/ResourceAble/BDB.pm lib/TM/ResourceAble/MemCached.pm lib/TM/Serializable/AsTMa.pm lib/TM/Serializable/CTM.pm lib/TM/Serializable/Dumper.pm lib/TM/Serializable/LTM.pm lib/TM/Serializable/Summary.pm lib/TM/Serializable/XTM.pm lib/TM/Serializable/JTM.pm lib/TM/Serializable/CSV.pm lib/TM/Serializable.pm lib/TM/Synchronizable/MapSphere.pm lib/TM/Synchronizable/MLDBM.pm lib/TM/Synchronizable/Null.pm lib/TM/Synchronizable.pm lib/TM/Tau/Federate.pm lib/TM/Tau/Filter.pm lib/TM/Tau/Filter/Analyze.pm lib/TM/Tau.pm lib/TM/Tree.pm lib/TM/Utils.pm lib/TM/Utils/TreeWalker.pm lib/TM/Workbench/Plugin.pm lib/TM/Workbench/Plugin/Test.pm lib/TM/Workbench/Plugin/Tau.pm bin/tm support/mkaxespod.pl support/mkcoveragepod.pl examples/01_low_level.pl examples/02_astma.pl examples/03_mldbm.pl examples/04_mldbm2.pl examples/05_traits.pl examples/old_testament.atm examples/06_diff.pl examples/08_tmdm.pl examples/09_opera.pl examples/10_mldbm.t examples/11_tmql.pl examples/12_index.pl TM-1.56/yapp/0000755000175000017500000000000011465717610011110 5ustar rhorhoTM-1.56/yapp/YappTemplate.pm0000644000175000017500000000163110777176261014062 0ustar rhorho#################################################################### # # This file was generated using Parse::Yapp version <<$version>>. # # Don't edit this file, use source file instead. # # ANY CHANGE MADE HERE WILL BE LOST ! # #################################################################### package <<$package>>; use vars qw ( @ISA ); use strict; @ISA= qw ( Parse::Yapp::Driver ); <<$driver>> <<$head>> sub new { my $class = shift; my %options = @_; my $store = delete $options{store} || new TM; # the Yapp parser is picky and interprets this :-/ ref($class) and $class=ref($class); my $self = $class->SUPER::new( ## yydebug => 0x01, yyversion => '<<$version>>', yystates => <<$states>>, yyrules => <<$rules>>, %options); $self->{USER}->{store} = $store; return bless $self, $class; } <<$tail>> 1; TM-1.56/yapp/astma-fact.yp0000644000175000017500000005410411417253241013476 0ustar rhorho%{ use Data::Dumper; use TM; use TM::Literal; use constant LEFT => 'http://psi.tm.bond.edu.au/astma/1.0/#psi-left'; use constant RIGHT => 'http://psi.tm.bond.edu.au/astma/1.0/#psi-right'; my $tracing = 0; %} %token ISA %token BN %token OC %token IN %token SIN %token COMMENT %token STRING %token EOL %token ID %token REIFIES %token ISREIFIED %token ISINDICATEDBY %token LOG %token CANCEL %token TRACE %token ENCODING %token COLON %token LPAREN %token RPAREN %token LBRACKET %token RBRACKET %token AT %% maplet_definitions : #empty | maplet_definitions maplet_definition | maplet_definitions template_definition EOL | maplet_definitions COMMENT EOL | maplet_definitions LOG EOL { warn "Logging $_[2]"; } | maplet_definitions CANCEL EOL { die "Cancelled"; } | maplet_definitions TRACE EOL { $tracing = $_[2]; warn "# start tracing: level $tracing"; } | maplet_definitions ENCODING EOL { use Encode; Encode::from_to ($_[0]->YYData->{INPUT}, "iso-8859-1", $_[2]); } ; maplet_definition : topic_definition | association_definition | EOL ; topic_definition : ID types reification_indication inline_assocs EOL { $_[1] = $_[0]->{USER}->{store}->internalize ($_[1]); if (ref $_[3]) { # we have reification info if ( $_[3]->[0] == 1) { # 1 = REIFIES, means current ID is a shorthand for the other $_[0]->{USER}->{store}->internalize ($_[1] => $_[3]->[1]); } elsif ($_[3]->[0] == 0) { # 0 = IS-REIFIED, this must be the other way round $_[0]->{USER}->{store}->internalize ($_[3]->[1] => $_[1]); } elsif ($_[3]->[0] == 2) { # 2 = ISINDICATEDBY, add the subject indicators $_[0]->{USER}->{store}->internalize ($_[1] => \ $_[3]->[1]); } else { die "internal fu**up"; } } # assert instance/class if (@{$_[2]}) { $_[0]->{USER}->{store}->assert ( map { bless [ undef, undef, 'isa', undef, [ 'class', 'instance' ], [ $_, $_[1] ], ], 'Assertion' } @{$_[2]} ); } { # memorize the types should be a 'topic' # at the end (see end of parse) my $implicits = $_[0]->{USER}->{implicits}; map { $implicits->{'isa-thing'}->{$_}++ } (@{$_[2]}, $_[1]); # the types and the ID are declared implicitely } if (ref $_[4]) { # there are inline assocs foreach (@{$_[4]}) { my $type = $_->[0]; my $player = $_->[1]; my $store = $_[0]->{USER}->{store}; my $templates = $_[0]->{USER}->{templates}; if ($type eq 'is-subclass-of' || $type eq 'subclasses') { $store->assert (bless [ undef, # LID undef, # SCOPE 'is-subclass-of', # TYPE TM->ASSOC, # KIND [ 'subclass', 'superclass' ], # ROLES [ $_[1], $player ], # PLAYERS undef ], 'Assertion' ); } elsif ($type eq 'is-a') { $store->assert (bless [ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $_[1], $player ], # PLAYERS undef ], 'Assertion' ); } elsif ($type eq 'has-a') { # same, but other way round $store->assert (bless [ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $player, $_[1] ], # PLAYERS undef ], 'Assertion' ); } elsif ($templates->tids ( $type ) && (my @ts = $templates->match (TM->FORALL, type => $templates->tids ( $type ) ))) { warn "duplicate template for '$type' found (maybe typo?), taking one" if @ts > 1; my $t = $ts[0]; # I choose one $store->assert (bless [ undef, # LID undef, # SCOPE $type, # TYPE TM->ASSOC, # KIND [ # ROLES map { my $l = $templates->toplet ($_)->[TM->ADDRESS]; ($l && $l eq LEFT ? $_[1] : ($l && $l eq RIGHT ? $player : $_) ) } @{$t->[TM->ROLES]} ], [ # PLAYERS map { my $l = $templates->toplet ($_)->[TM->ADDRESS]; ($l && $l eq LEFT ? $_[1] : ($l && $l eq RIGHT ? $player : $_) ) } @{$t->[TM->PLAYERS]} ], undef ], 'Assertion' ); } else { die "unknown association type '$type' in inlined association"; } } } warn "added toplet $_[1]" if $tracing; } characteristics_indication { #warn "char/ind in topic: ".Dumper $_[7]; my $id = $_[1]; # add assertions for every characteristic $_[0]->{USER}->{store}->assert ( map {bless [ undef, # LID $_->[1], # SCOPE $_->[2] || # TYPE ($_->[0] == TM->NAME ? 'name' : 'occurrence'), $_->[0], # KIND [ 'thing', 'value' ], # ROLES [ $id, $_->[3] ], # PLAYERS undef ], 'Assertion' } @{$_[7]->[0]} ); map { $store->internalize ($id => \ $_ ) } @{$_[7]->[1]}; # add the subject indicators { # memorize basename types and scopes as implicitely defined my $implicits = $_[0]->{USER}->{implicits}; map { $implicits->{'isa-scope'}->{$_}++ } map { $_->[1] } grep ($_->[1], @{$_[7]->[0]}); # get the bloody scopes and tuck them away map { $implicits->{'subclasses'}->{ $_->[0] == TM->NAME ? 'name' : 'occurrence' }->{$_->[2]}++ } grep ($_->[2], @{$_[7]->[0]}); # get all the characteristics with types } warn "added ".(scalar @{$_[7]->[0]})."characteristics for $_[1]" if $tracing > 1; } ; reification_indication : # empty | REIFIES ID { [ 1, $_[2] ] } # 0, 1, 2 are just local encoding, nothing relevant | ISREIFIED ID { [ 0, $_[2] ] } | ISINDICATEDBY ID { [ 2, $_[2] ] } ; types : { [] } # empty | types type { push @{$_[1]}, @{$_[2]}; $_[1] } ; type : ISA ID { [ $_[2] ] } | LPAREN ids RPAREN { $_[2] } ; characteristics_indication : # empty | characteristics_indication characteristic_indication { push @{$_[1]->[ ref($_[2]) eq 'ARRAY' ? 0 : 1 ]}, $_[2]; $_[1] } ; # do not tell me this is not cryptic, it fast, though # if we get a characteristic back, then it is a list ref, then we add it to $_[1]->[0] # if we get a subject indication back, then it is a scalar, so we add it to $_[1]->[1] characteristic_indication : characteristic | indication ; indication : SIN { $_[0]->{USER}->{string} ||= "\n" } string { $_[3] } # TODO: replace with ID? ; characteristic : class { $_[0]->{USER}->{string} ||= "\n" } scope char_type string { # check whether we are dealing with URIs or strings if ($_[1] == TM->NAME) { # names are always strings $_[5] = new TM::Literal ($_[5], TM::Literal->STRING); } elsif ($_[5] =~ /^\w+:\S+$/) { # can only be OCC, but is it URI? $_[5] = new TM::Literal ($_[5], TM::Literal->URI); } else { # occurrence and not a URI -> string $_[5] = new TM::Literal ($_[5], TM::Literal->STRING); } ## warn "char ".Dumper [ $_[1], $_[3], $_[4], $_[5] ]; [ $_[1], $_[3], $_[4], $_[5] ] } ; class : BN { TM->NAME } | OC { TM->OCC } | IN { TM->OCC } ; char_type : # empty | assoc_type ; assoc_type : LPAREN ID RPAREN { $_[2] } ; scope : # empty | AT ID { $_[2] } ; inline_assocs : # empty | inline_assocs inline_assoc { push @{$_[1]}, $_[2]; $_[1] } ; inline_assoc : ID ID { [ $_[1], $_[2] ] } ; template_definition : LBRACKET { ($_[0]->{USER}->{templates}, $_[0]->{USER}->{store}) = ($_[0]->{USER}->{store}, $_[0]->{USER}->{templates}); } # flag that we are inside a template association_definition { ($_[0]->{USER}->{templates}, $_[0]->{USER}->{store}) = ($_[0]->{USER}->{store}, $_[0]->{USER}->{templates}); } #RBRACKET # consumed by members already ; association_definition : LPAREN ID RPAREN scope reification_indication EOL association_members { ##warn "members ".Dumper $_[5]; ## ??? TODO SCOPE ???? my (@roles, @players); foreach my $m (@{$_[7]}) { # one member my $role = shift @$m; # first is role while (@$m) { push @roles, $role; # roles repeat for every player my $player = shift @$m; push @players, $player; } } my ($a) = $_[0]->{USER}->{store}->assert (bless [ undef, $_[4], $_[2], TM->ASSOC, \@roles, \@players, undef ], 'Assertion'); ##warn "templates" .Dumper $_[0]->{USER}->{store}; { # reification my $ms = $_[0]->{USER}->{store}; if (ref $_[5]) { if ($_[5]->[0] == 1) { # 1 = REIFIES, 0 = IS-REIFIED # (assoc) reifies http://.... means # 1) the assoc will be addes as thing (is done already) # 2) the http:// will be used as one subject indicator die "reifier of association must be a URI" unless $_[5]->[1] =~ /^\w+:.+/; $ms->internalize ($a->[TM::LID], $_[5]->[1]); } elsif ($_[5]->[0] == 0) { # something reifies this assoc # (assoc) is-reified-by xxx means # 1) assoc is added as thing (is done already) # 2) the local identifier is added as thing with the abs URL of the assoc as subject address die "reifier must be local identifier" unless $_[5]->[1] =~ /^[A-Za-z][A-Za-z0-9_\.-]+$/; $ms->internalize ($_[5]->[1] => $a); } else { # this would be 'indication' but we do not want that here die "indication for associations are undefined"; } } } { # memorize that association type subclasses association # my $implicits = $_[0]->{USER}->{implicits}; # implicit $implicits->{'subclasses'}->{'association'}->{$_[2]}++; $_[0]->{USER}->{implicits}->{'isa-scope'}->{$_[4]}++ if $_[4]; } warn "added assertion $_[2]" if $tracing; } ; association_members : member { [ $_[1] ] } | association_members member { push @{$_[1]}, $_[2]; $_[1] } ; member : ID COLON ids1 eom { [ $_[1], @{$_[3]} ] } ; eom : EOL # normal assoc | RBRACKET EOL # in case we are inside a template ; ids1 : ids ID { push @{$_[1]}, $_[2]; $_[1] } ; ids : { [] } # empty | ids ID { push @{$_[1]}, $_[2]; $_[1] } ; string : STRING EOL { die "empty string in characteristics" unless $_[1]; $_[1] } ; %% sub _Error { die "Syntax error: Found ".$_[0]->YYCurtok." but expected ".join (' or ', $_[0]->YYExpect); } use constant CHUNK_SIZE => 32000; sub _Lexer { my $parser = shift; my $yydata = $parser->YYData; if (length ($yydata->{INPUT}) < 1024 && $yydata->{OFFSET} < $yydata->{TOTAL}) { $yydata->{INPUT} .= substr ($yydata->{RESERVE}, $yydata->{OFFSET}, CHUNK_SIZE); $yydata->{OFFSET} += CHUNK_SIZE; } my $refINPUT = \$yydata->{INPUT}; my $aux; # need this to store identifier/uri prefix for optimization $$refINPUT or return ('', undef); $$refINPUT =~ s/^[ \t]+//so; #warn "lexer ($parser->{USER}->{string}):>>>".$parser->YYData->{INPUT}."<<<"; $$refINPUT =~ s/^\n//so and return ('EOL', undef); $$refINPUT =~ s/^in\b(?![\.-])//o and return ('IN', undef); $$refINPUT =~ s/^rd\b(?![\.-])//o and return ('IN', undef); $$refINPUT =~ s/^oc\b(?![\.-])//o and return ('OC', undef); $$refINPUT =~ s/^ex\b(?![\.-])//o and return ('OC', undef); $$refINPUT =~ s/^bn\b(?![\.-])//o and return ('BN', undef); $$refINPUT =~ s/^sin\b(?![\.-])//o and return ('SIN', undef); $$refINPUT =~ s/^is-a\b(?![\.-])//o and return ('ISA', undef); $$refINPUT =~ s/^reifies\b(?![\.-])//o and return ('REIFIES', undef); $$refINPUT =~ s/^=//o and return ('REIFIES', undef); $$refINPUT =~ s/^is-reified-by\b(?![\.-])//o and return ('ISREIFIED', undef); $$refINPUT =~ s/^~//o and return ('ISINDICATEDBY', undef); if (my $t = $parser->{USER}->{string}) { # parser said we should expect a string now, defaults terminator to \n ##warn "scanning for string (..$t..) in ...". $$refINPUT . "...."; $$refINPUT =~ s/^:\s*<<<\n/:/o and # we know it better, it is <<< $t = "\n<<<\n"; $$refINPUT =~ s/^:\s*<<(\w+)\n/:/o and # we know it better, it is <{USER}->{string} or return ('STRING', $1)); ##warn "no string"; } $$refINPUT =~ s/^://o and return ('COLON', undef); ## unfortunately, this does not what I want ## $$refINPUT =~ s/^([A-Za-z][A-Za-z0-9_-]*)(?!:)//o and return ('ID', $1); # negative look-ahead ## tricky optimization: don't ask $$refINPUT =~ s/^([A-Za-z][.A-Za-z0-9_-]*)//o and $aux = $1 # save this for later and $$refINPUT !~ /^:[\w\/]/ and return ('ID', $aux); $$refINPUT =~ s/^\(//so and return ('LPAREN', undef); $$refINPUT =~ s/^\)//so and return ('RPAREN', undef); $$refINPUT =~ s/^@//so and return ('AT', undef); $$refINPUT =~ s/^(:[^\s\)\(\]\[]+)//o and return ('ID', $aux.$1); # is a URL/URN actually $$refINPUT =~ s/^(\d{4}-\d{1,2}-\d{1,2})(\s+(\d{1,2}):(\d{2}))?//o and return ('ID', sprintf "urn:x-date:%s:%02d:%02d", $1, $3 || 0, $4 || 0); # is a date $$refINPUT =~ s/^%log\s+(.*?)(?=\n)//so and return ('LOG', $1); # positive look-ahead $$refINPUT =~ s/^%cancel\s*(?=\n)//so and return ('CANCEL', $1); # positive look-ahead $$refINPUT =~ s/^%trace\s+(.*?)(?=\n)//so and return ('TRACE', $1); # positive look-ahead $$refINPUT =~ s/^%encoding\s+(.*?)(?=\n)//so and return ('ENCODING', $1); # positive look-ahead $$refINPUT =~ s/^\*//o and return ('ID', sprintf "uuid-%010d", $TM::toplet_ctr++); ## $parser->{USER}->{topic_count}++); $$refINPUT =~ s/^\[//so and return ('LBRACKET', undef); $$refINPUT =~ s/^\]//so and return ('RBRACKET', undef); # should not be an issue except on error $$refINPUT =~ s/^(.)//so and return ($1, $1); } sub parse { my $self = shift; $_ = shift; s/\r\n/\n/sg; s/\r/\n/sg; s/(? gone s/\s\#.*?\n/\n/mg; # anything which starts with # -> gone s/(?{USER}->{implicits} = { 'isa-thing' => undef, # just let them spring into existence 'isa-scope' => undef, # just let them spring into existence 'subclasses' => undef }; # clone a pseudo map into which to store templates as assocs temporarily $self->{USER}->{templates} = new TM (baseuri => $self->{USER}->{store}->baseuri); $self->YYData->{INPUT} = ''; $self->YYData->{RESERVE} = $_; # here we park the whole string $self->YYData->{TOTAL} = length ($_); # this is how much we have in the reserve $self->YYData->{OFFSET} = 0; # and we start at index 0 eval { $self->YYParse ( yylex => \&_Lexer, yyerror => \&_Error ); }; if ($@ =~ /^Cancelled/) { warn $@; # de-escalate Cancelling to warning } elsif ($@) { die $@; # otherwise re-raise the exception } { # resolving implicit stuff my $implicits = $self->{USER}->{implicits}; my $store = $self->{USER}->{store}; { # all super/subclasses foreach my $superclass (keys %{$implicits->{'subclasses'}}) { $store->assert ( map { bless [ undef, undef, 'is-subclass-of', TM->ASSOC, [ 'superclass', 'subclass' ], [ $superclass, $_ ] ], 'Assertion' } keys %{$implicits->{'subclasses'}->{$superclass}}); } #warn "done with subclasses"; } { # all things in isa-things are THINGS, simply add them ##warn "isa things ".Dumper [keys %{$implicits->{'isa-thing'}}]; $store->internalize (map { $_ => undef } keys %{$implicits->{'isa-thing'}}); } { # establishing the scoping topics $store->assert (map { bless [ undef, undef, 'isa', TM->ASSOC, [ 'class', 'instance' ], [ 'scope', $_ ] ], 'Assertion' } keys %{$implicits->{'isa-scope'}}); } } return $self->{USER}->{store}; } #my $f = new TM::AsTMa::Fact; #$f->Run; TM-1.56/yapp/astma2-fact.yp0000644000175000017500000011504310777176261013576 0ustar rhorho%{ use Data::Dumper; use TM; use TM::Literal; use constant { XSD => 'http://www.w3.org/2001/XMLSchema', XSD_STRING => 'http://www.w3.org/2001/XMLSchema#string', ASTMA => 'http://psi.tm.bond.edu.au/astma/2.0/', ONTOLOGY => 'http://psi.tm.bond.edu.au/astma/2.0/#ontology', TEMPLATE => 'http://psi.tm.bond.edu.au/astma/2.0/#template' }; sub _expand_template { my $store = shift; my $ted = shift; my $params = shift; # they are all strings at this level #warn "params".Dumper $params; my @returns = $store->match (TM->FORALL, type => 'return', irole => 'thing', iplayer => $store->tids ($ted) ) or die "template '$ted' does not have a 'return' characteristic"; #warn Dumper \@returns; my $return = $returns[0]->[TM->PLAYERS]->[1] and (scalar @returns == 1 or die "ambiguous 'return' characteristics for '$ted'"); my $value = $return->[0] and ($return->[1] eq 'http://www.w3.org/2001/XMLSchema#string' or die "'return' characteristic of '$ted' is no string"); #warn "template id '$ted' >>>$value<<<"; foreach my $p (keys %$params) { $value =~ s/{\s*\$$p\s*}/$params->{$p}/sg; } #warn "after template id '$ted' >>>$value<<<"; die "variable '$1' in template '$ted' has no value at expansion" if $value =~ /{\s*(\$\w+)\s*}/; return $value; } %} %token DUMMY %token EOL %token DOT %token BRA %token KET %token URI %token TILDE %token EQUAL %token COLON %token NAME %token OCC %token VALUE %token HAS %token DOWNCOMMA %token COMMA %token WHICH %token TED %token REIFIES %token ISREIFIED %token LPAREN %token RPAREN %token SUBCL %token ISA %token LOG %token CANCEL %token VERSION %token INCLUDE %token COMMENT %token WILDCARD %token DATE %token BN %token OC %token IN %token SIN %token STRING %token ID %token ISINDICATEDBY %token LBRACKET %token RBRACKET %token AT %% instance : # empty | instance EOL | instance clause ; clause : { $_[0]->{USER}->{ctx} = undef; } theme DOT | template_expansion | directive ; directive : CANCEL { die "Cancelled"; } | LOG { warn $_[1]; 1; } # write message to STDERR | VERSION { die "unsupported version $_[1]" unless $_[1] =~ /^2\./; 1; } | INCLUDE { my $content; if ($_[1] =~ /\|\s*$/) { # a pipe | at the end, this is a UNIX pipe my $fh = IO::File->new ($_[1]) || die "unable to open pipe '$_[1]'"; local $/ = undef; $content = <$fh>; $fh->close; } else { use LWP::Simple; $content = get($_[1]) || die "unable to load '$_[1] with LWP'\n"; } #warn "new content >>>$content<<<"; $_[0]->YYData->{INPUT} = $content . $_[0]->YYData->{INPUT}; # prepend it } | ENCODING { use Encode; Encode::from_to ($_[0]->YYData->{INPUT}, "iso-8859-1", $_[1]); } ; template_expansion : TED parameters { $_[0]->YYData->{INPUT} .= "\n" . _expand_template ($_[0]->{USER}->{store}, $_[1], $_[2]) # compute the expanded version . "\n"; # extend the text at the end; } ; parameters : # empty { { } } | LPAREN bindings RPAREN { $_[2] } ; bindings : binding | bindings COMMA binding { $_[1] = { %{$_[1]}, %{$_[3]} }; $_[1]; } # combine the hashes ; binding : ID COLON { $_[0]->{USER}->{value} = 1 } VALUE { { "$_[1]" => $_[4]->[0] } } # create a small hash (and use the string) ; theme : BRA topic KET | topic ; topic : { unshift @{$_[0]->{USER}->{ctx}}, undef; } # push a (yet unknown) topic attachments association ; association : # empty | REIFIES { $_[0]->{USER}->{reifier} = $_[0]->{USER}->{ctx}->[0]; $_[0]->{USER}->{ctx}->[0] = undef; } identification { $_[0]->{USER}->{atype} = $_[0]->{USER}->{ctx}->[0]; $_[0]->{USER}->{assoc} = 1; # indicate to lexer that we are in assoc context } scope rolesin roles rolesout { # warn "roles :". Dumper $_[7]; $_[0]->{USER}->{store}->assert ([ $_[0]->{USER}->{reifier}, # LID $_[5], # SCOPE $_[0]->{USER}->{atype}, # TYPE TM->ASSOC, # KIND @{$_[7]}, # ROLES, PLAYERS undef ] ); $_[0]->{USER}->{implicits}->{'isa-scope'}->{$_[5]}++ if $_[5]; $_[0]->{USER}->{assoc} = undef; # indicate to lexer that we left assoc context } ; rolesin : LPAREN | EOL ; rolesout : # empty | RPAREN | EOL ; rolesep : COMMA | EOL ; roles : role | roles rolesep role { push @{$_[1]->[0]}, @{$_[3]->[0]}; push @{$_[1]->[1]}, @{$_[3]->[1]}; $_[1]; } ; role : topic { $_[0]->{USER}->{role} = $_[0]->{USER}->{ctx}->[0] } COLON { $_[0]->{USER}->{ctx}->[0] = undef } # clean out context identifications { [ [ ($_[0]->{USER}->{role}) x scalar @{$_[5]} ], $_[5] ] } ; identifications : identification { $_[0]->{USER}->{ctx}->[0] = undef } # clean out context here { [ $_[1] ] } | identifications identification { $_[0]->{USER}->{ctx}->[0] = undef } { push @{$_[1]}, $_[2]; $_[1]; } ; attachments : # empty | attachments HAS characteristic | attachments WHICH HAS characteristic | attachments expansion | attachments WHICH expansion | attachments identification | attachments EOL identification ; relative : # empty | DOWNCOMMA attachments upcomma ; upcomma : # empty | COMMA ; predefined_inlines : ISA { 'isa' } | SUBCL { 'subclasses' } | TED ; expansion : predefined_inlines parameters { unshift @{$_[0]->{USER}->{ctx}}, undef; } identification { # warn " expand ctx ".Dumper $_[0]->{USER}->{ctx}; my $left = $_[0]->{USER}->{ctx}->[1]; my $ted = $_[1]; my $right = $_[0]->{USER}->{ctx}->[0]; my $store = $_[0]->{USER}->{store}; my $params = $_[2]; #warn "left $left ted $ted right $right"; if ($ted eq 'subclasses') { $store->assert ([ undef, # LID undef, # SCOPE 'is-subclass-of', # TYPE TM->ASSOC, # KIND [ 'subclass', 'superclass' ], # ROLES [ $left, $right ], # PLAYERS undef ] ); } elsif ($ted eq 'isa') { $store->assert ([ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $left, $right ], # PLAYERS undef ] ); } elsif ($ted eq 'hasa') { # same, but other way round $store->assert ([ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $right, $left ], # PLAYERS undef ] ); } else { $_[0]->YYData->{INPUT} .= "\n" . _expand_template ($store, $ted, { %$params, '_left' => $left, '_right' => $right}) # compute the expanded version . "\n"; # extend the text at the end; } } relative { shift @{$_[0]->{USER}->{ctx}}; } # clean out context ; identification : tid { # warn "tid: >>".$_[1]."<<"; if (! defined $_[1]) { # wildcard $_[0]->{USER}->{ctx}->[0] ||= $_[0]->{USER}->{store}->internalize (sprintf "uuid-%010d", $TM::toplet_ctr++); } elsif (ref ($_[1])) { # reference means indicator $_[0]->{USER}->{ctx}->[0] = $_[0]->{USER}->{store}->internalize ($_[0]->{USER}->{ctx}->[0] => $_[1]); } elsif ($_[1] =~ /^\w+:.+/) { # URI means subject address $_[0]->{USER}->{ctx}->[0] = $_[0]->{USER}->{store}->internalize ($_[0]->{USER}->{ctx}->[0] => $_[1]); } else { # some lousy identifier # warn "checking for context ".Dumper $_[0]->{USER}->{ctx}->[0] ; die "duplicate ID: $_[1] and $_[0]->{USER}->{ctx}->[0]" if ($_[0]->{USER}->{ctx}->[0]); # we already have an identifier! $_[0]->{USER}->{ctx}->[0] = $_[0]->{USER}->{store}->internalize ($_[1]); } $_[1] = $_[0]->{USER}->{ctx}->[0]; # whatever that was, that's it } ; characteristic : tid scope type COLON { $_[0]->{USER}->{value} = 1 } VALUE { my $ctype = $_[1]; my $cclass; # we do not yet know what this will be if ($_[3]) { # there is a type specified $cclass = $_[3]; # take this to be the class of what ctype is } elsif ($_[1] =~ /.*name$/) { # looks like a name if ($_[6]->[1] eq XSD_STRING) { # but we check first what type the value is $cclass = 'name'; # for a string we allow it to be a name } else { $cclass = 'occurrence'; # otherwise, we guess it is an occurrence } } else { # type does not end with 'name' $cclass = 'occurrence'; # this is then an occurrence } if ($cclass ne $ctype) { # a new instance was introduced $store->assert ([ undef, # LID undef, # SCOPE 'is-subclass-of', # TYPE TM->ASSOC, # KIND [ 'subclass', 'superclass' ], # ROLES [ $ctype, $cclass ], # PLAYERS undef ] ); } # warn "char $_[1] ctx ".Dumper $_[0]->{USER}->{ctx}; $_[0]->{USER}->{store}->assert ( # [ undef, # LID $_[2], # SCOPE (undef is ok) $_[1], # TYPE $cclass eq 'name' ? TM->NAME : ($cclass eq 'occurrence' ? TM->OCC : TM->ASSOC), # KIND [ 'thing', 'value' ], # ROLES [ $_[0]->{USER}->{ctx}->[0], $_[6] ], # PLAYERS undef ] ); } ; scope : # empty | AT tid { $_[2]; } ; type : # empty | SUBCL tid { $_[2] } ; ctype : NAME | OCC ; tid : ID { $_[1]; } | WILDCARD { undef; } # make sure we have an ID | DATE { \ $_[1]; } | EQUAL URI { $_[2]; } | TILDE URI { \ $_[2]; } | URI { my $baseuri = $_[0]->{USER}->{store}->baseuri; $_[1] =~ /^$baseuri(.+)/ ? $1 : \ $_[1]; } ; #------------------------------------------- xinstance : # empty | instance EOL | instance theme ; xxxtopic : identification involvements ; xinvolvements : # empty | involvements involvement ; involvement : identification | AND attachment | attachment | LRELATIVE relative RRELATIVE ; xattachment : statement ; statement : ISA topic ; xxtopic : tid { warn "involve ".Dumper $_[2]; 1; } ; tids : tid { [ $_[1] ] } # singleton | tids tid { push @{$_[1]}, $_[2]; $_[1] } ; involvements : { [] } #empty | involvements inlined_expansion { push @{$_[1]}, $_[2]; $_[1] } ; inlined_expansion : LPAREN tids RPAREN { $_[2] } ; #types : { [] } # empty # | types type { push @{$_[1]}, @{$_[2]}; $_[1] } #; # #type : ISA ID { [ $_[2] ] } # | LPAREN ids RPAREN { $_[2] } #; xtopic : ID types reification_indication inline_assocs EOL { $_[1] = $_[0]->{USER}->{store}->internalize ($_[1]); if (ref $_[3]) { # we have reification info if ( $_[3]->[0] == 1) { # 1 = REIFIES, means current ID is a shorthand for the other $_[0]->{USER}->{store}->internalize ($_[1] => $_[3]->[1]); } elsif ($_[3]->[0] == 0) { # 0 = IS-REIFIED, this must be the other way round $_[0]->{USER}->{store}->internalize ($_[3]->[1] => $_[1]); } elsif ($_[3]->[0] == 2) { # 2 = ISINDICATEDBY, add the subject indicators $_[0]->{USER}->{store}->internalize ($_[1] => \ $_[3]->[1]); } else { die "internal fu**up"; } } # assert instance/class if (@{$_[2]}) { $_[0]->{USER}->{store}->assert ( map { [ undef, undef, 'isa', undef, [ 'class', 'instance' ], [ $_, $_[1] ], ]} @{$_[2]} ); } { # memorize that the types should be a 'topic' at the end (see end of parse) my $implicits = $_[0]->{USER}->{implicits}; # my $s = $_[0]->{USER}->{store}; map { $implicits->{'isa-thing'}->{$_}++ } (@{$_[2]}, $_[1]); # the types and the ID are declared implicitely } if (ref $_[4]) { # there are inline assocs #warn "test for inlines"; foreach (@{$_[4]}) { my $type = $_->[0]; my $player = $_->[1]; my $store = $_[0]->{USER}->{store}; my $templates = $_[0]->{USER}->{templates}; #warn "found type $type $player"; if ($type eq 'is-subclass-of' || $type eq 'subclasses') { $store->assert ([ undef, # LID undef, # SCOPE 'is-subclass-of', # TYPE TM->ASSOC, # KIND [ 'subclass', 'superclass' ], # ROLES [ $_[1], $player ], # PLAYERS undef ] ); } elsif ($type eq 'is-a') { $store->assert ([ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $_[1], $player ], # PLAYERS undef ] ); } elsif ($type eq 'has-a') { # same, but other way round $store->assert ([ undef, # LID undef, # SCOPE 'isa', # TYPE TM->ASSOC, # KIND [ 'instance', 'class' ], # ROLES [ $player, $_[1] ], # PLAYERS undef ] ); } elsif ($templates->tids ( $type ) && (my @ts = $templates->match (TM->FORALL, type => $templates->tids ( $type ) ))) { #warn "found templates for $type"; warn "duplicate template for '$type' found, taking one" if @ts > 1; my $t = $ts[0]; # I choose one #warn "YYY cloning ($type)"; $store->assert ([ undef, # LID undef, # SCOPE $type, # TYPE TM->ASSOC, # KIND [ # ROLES map { my $l = $templates->reified_by ($_); ($l && $l eq LEFT ? $_[1] : ($l && $l eq RIGHT ? $player : $_) ) } @{$t->[TM->ROLES]} ], [ # PLAYERS map { my $l = $templates->reified_by ($_); ($l && $l eq LEFT ? $_[1] : ($l && $l eq RIGHT ? $player : $_) ) } @{$t->[TM->PLAYERS]} ], undef ] ); } else { die "unknown association type '$type' in inlined association"; } } } } characteristics_indication { #warn "char/ind in topic: ".Dumper $_[7]; my $id = $_[1]; # add assertions for every characteristic $_[0]->{USER}->{store}->assert ( map {[ undef, # LID $_->[1], # SCOPE $_->[2] || $TM::CharInfo[$_->[0]]->[0], # TYPE $_->[0], # KIND [ 'thing', $TM::CharInfo[$_->[0]]->[1] ], # ROLES [ $id, $_->[3] ], # PLAYERS undef ] } @{$_[7]->[0]} ); map { $store->internalize ($id => $_ ) } @{$_[7]->[1]}; # add the subject indicators { # memorize basename types and scopes as implicitely defined my $implicits = $_[0]->{USER}->{implicits}; map { $implicits->{'isa-scope'}->{$_}++ } map { $_->[1] } grep ($_->[1], @{$_[7]->[0]}); # get the bloody scopes and tuck them away map { $implicits->{'subclasses'}->{ $TM::CharInfo[$_->[0]]->[0] }->{$_->[2]}++ } grep ($_->[2], @{$_[7]->[0]}); # get all the characteristics with types #warn "implicits then ".Dumper $implicits; } } ; reification_indication : # empty | REIFIES ID { [ 1, $_[2] ] } # 0, 1, 2 are just local encoding, nothing relevant | ISREIFIED ID { [ 0, $_[2] ] } | ISINDICATEDBY ID { [ 2, $_[2] ] } ; types : { [] } # empty | types type { push @{$_[1]}, @{$_[2]}; $_[1] } ; xtype : ISA ID { [ $_[2] ] } | LPAREN ids RPAREN { $_[2] } ; characteristics_indication : # empty | characteristics_indication characteristic_indication { push @{$_[1]->[ ref($_[2]) eq 'ARRAY' ? 0 : 1 ]}, $_[2]; $_[1] } ; # do not tell me this is not cryptic, it fast, though # if we get a characteristic back, then it is a list ref, then we add it to $_[1]->[0] # if we get a subject indication back, then it is a scalar, so we add it to $_[1]->[1] xcharacteristic_indication : characteristic | indication ; indication : SIN { $_[0]->{USER}->{string} ||= "\n" } string { $_[3] } # TODO: replace with ID? ; class : BN { TM->KIND_BN } | OC { TM->KIND_OC } | IN { TM->KIND_IN } ; char_type : # empty | assoc_type ; assoc_type : LPAREN ID RPAREN { $_[2] } ; inline_assocs : # empty | inline_assocs inline_assoc { push @{$_[1]}, $_[2]; $_[1] } ; inline_assoc : ID ID { [ $_[1], $_[2] ] } ; template_definition : LBRACKET { ($_[0]->{USER}->{templates}, $_[0]->{USER}->{store}) = ($_[0]->{USER}->{store}, $_[0]->{USER}->{templates}); } # flag that we are inside a template association_definition { ($_[0]->{USER}->{templates}, $_[0]->{USER}->{store}) = ($_[0]->{USER}->{store}, $_[0]->{USER}->{templates}); } #RBRACKET # consumed by members already ; association_definition : LPAREN ID RPAREN scope reification_indication EOL association_members { ##warn "members ".Dumper $_[5]; ## ??? TODO SCOPE ???? my (@roles, @players); foreach my $m (@{$_[7]}) { # one member my $role = shift @$m; # first is role while (@$m) { push @roles, $role; # roles repeat for every player my $player = shift @$m; push @players, $player; } } my ($a) = $_[0]->{USER}->{store}->assert ( [ undef, $_[4], $_[2], TM->ASSOC, \@roles, \@players, undef ] ); ##warn "templates" .Dumper $_[0]->{USER}->{store}; { # reification my $ms = $_[0]->{USER}->{store}; if (ref $_[5]) { if ($_[5]->[0] == 1) { # 1 = REIFIES, 0 = IS-REIFIED # (assoc) reifies http://.... means # 1) the assoc will be addes as thing (is done already) # 2) the http:// will be used as one subject indicator die "reifier of association must be a URI" unless $_[5]->[1] =~ /^\w+:.+/; $ms->internalize ($a->[TM::LID], $_[5]->[1]); } elsif ($_[5]->[0] == 0) { # something reifies this assoc # (assoc) is-reified-by xxx means # 1) assoc is added as thing (is done already) # 2) the local identifier is added as thing with the abs URL of the assoc as subject address die "reifier must be local identifier" unless $_[5]->[1] =~ /^\w+$/; $ms->internalize ($_[5]->[1] => $a->[TM::LID]); } else { # this would be 'indication' but we do not want that here die "indication for association are undefined"; } } } { # memorize that association type subclasses association # my $implicits = $_[0]->{USER}->{implicits}; # implicit $implicits->{'subclasses'}->{'association'}->{$_[2]}++; $_[0]->{USER}->{implicits}->{'isa-scope'}->{$_[4]}++ if $_[4]; } } ; association_members : member { [ $_[1] ] } | association_members member { push @{$_[1]}, $_[2]; $_[1] } ; member : ID COLON ids1 eom { [ $_[1], @{$_[3]} ] } ; eom : EOL # normal assoc | RBRACKET EOL # in case we are inside a template ; ids1 : ids ID { push @{$_[1]}, $_[2]; $_[1] } ; ids : { [] } # empty | ids ID { push @{$_[1]}, $_[2]; $_[1] } ; string : STRING EOL { die "empty string in characteristics" unless $_[1]; \$_[1] } ; %% sub _Error { die "Syntax error: Found ".$_[0]->YYCurtok." but expected ".join (' or ', $_[0]->YYExpect); } sub _Lexer { my $parser = shift; my $refINPUT = \$parser->YYData->{INPUT}; # study $$refINPUT; $$refINPUT or return ('', undef); # this is the end of the world, as we know it $$refINPUT =~ s/^[ \t]+//o; #warn "lexer ($parser->{USER}->{string}):>>>".$parser->YYData->{INPUT}; $$refINPUT =~ s/^\n\n//so and return ('DOT', undef); $$refINPUT =~ s/^\n$//so and return ('DOT', undef); $$refINPUT =~ s/^\.//so and return ('DOT', undef); $$refINPUT =~ s/^\~//so and return ('TILDE', undef); $$refINPUT =~ s/^=//o and return ('EQUAL', undef); $$refINPUT =~ s/^://o and return ('COLON', undef); $$refINPUT =~ s/^,\s*(which|who)\b//o and return ('DOWNCOMMA', undef); $$refINPUT =~ s/^,(?!\s*(which|who)\b)//o and return ('COMMA', undef); $$refINPUT =~ s/^is-?a\b//o and return ('ISA', undef); # $$refINPUT =~ s/^has-?a\b//o and return ('TED', 'hasa'); $$refINPUT =~ s/^subclasses\b//o and return ('SUBCL', undef); $$refINPUT =~ s/^has\b//o and return ('HAS', undef); unless ($parser->{USER}->{assoc}) { # in topic context this corresponds to HAS $$refINPUT =~ s/^\n\s*(?=\w+\s*[:<@]\s)//so and return ('HAS', undef); # positive look-ahead for things like bn : } $$refINPUT =~ s/^(which|who)\b//o and return ('WHICH', undef); $$refINPUT =~ s/^and(\s+(which|who))?\b//so and return ('WHICH', undef); # (can go over lines) $$refINPUT =~ s/^\n//so and return ('EOL', undef); $$refINPUT =~ s/^{//so and return ('BRA', undef); $$refINPUT =~ s/^}//so and return ('KET', undef); $$refINPUT =~ s/^\(//so and return ('LPAREN', undef); $$refINPUT =~ s/^\)//so and return ('RPAREN', undef); $$refINPUT =~ s/^<>//o and return ('ISREIFIED', undef); $$refINPUT =~ s/^\*//o and return ('WILDCARD', undef); $$refINPUT =~ s/^(\d{4}-\d{1,2}-\d{1,2})(T(\d{1,2}):(\d{2}))?//o and return ('DATE', sprintf "urn:x-date:%s:%02d:%02d", $1, $3 || 0, $4 || 0); # is a date $$refINPUT =~ s/^bn\b//o and return ('ID', "name"); $$refINPUT =~ s/^oc\b//o and return ('ID', "occurrence"); $$refINPUT =~ s/^in\b//o and return ('ID', "occurrence"); if ($parser->{USER}->{value}) { # parser said we should expect a value now ##warn "expect value >>".$$refINPUT."<<"; $$refINPUT =~ s/^\"{3}(.*?)\"{3}(?=\n)//so and # (warn "returning multi $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1))); $$refINPUT =~ s/^\"(.*?)\"(^^(\S+))?//o and # (warn "returning simlg $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1, $3))); $$refINPUT =~ s/^(\d+\.\d+)//o and # (warn "returning float $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1, TM::Literal->DECIMAL))); $$refINPUT =~ s/^(\d+)//o and # (warn "returning int $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1, TM::Literal->INTEGER))); $$refINPUT =~ s/^(\w+:\S+)//o and # (warn "returning uri $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1, TM::Literal->URI))); $$refINPUT =~ s/^(.+?)(?=\s*\n)//o and # (warn "returning unquo $1" or 1) and (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1))); ## (warn "returning $1" or 1) and ## (undef $parser->{USER}->{value} or return ('VALUE', new TM::Literal ($1))); ##warn "no string"; } ## unfortunately, this does not what I want: ## $$refINPUT =~ s/^([A-Za-z][A-Za-z0-9_-]*)(?!:)//o and return ('ID', $1); # negative look-ahead ## tricky optimization: don't ask my $aux; # need this to store identifier/uri prefix temporarily (optimization) my $aux2; # need this to store ontology URL, if there is one $$refINPUT =~ s/^([A-Za-z][.A-Za-z0-9_-]*)//o and $aux = $1 # save this for later and $$refINPUT !~ /^:[\w\/]/ and return (_is_template ($parser->{USER}->{store}, $aux) ? 'TED' : 'ID', $aux); $$refINPUT =~ s/^(:([^\s\)\(\]\[]+))//o and return ('URI', ( $aux2 = _is_ontology ($parser->{USER}->{store}, $parser->{USER}->{prefixes}, $aux)) ? $aux2."#$2" : $aux.$1); # is a URL/URN actually $$refINPUT =~ s/^@//so and return ('AT', undef); $$refINPUT =~ s/^%include\s+(.*?)(?=\n)//so and return ('INCLUDE', $1); # positive look-ahead $$refINPUT =~ s/^%log\s+(.*?)(?=\n)//so and return ('LOG', $1); # positive look-ahead $$refINPUT =~ s/^%cancel(?=\n)//so and return ('CANCEL', $1); # positive look-ahead $$refINPUT =~ s/^%version\s+(\d+\.\d+)(?=\n)//so and return ('VERSION', $1); # positive look-ahead $$refINPUT =~ s/^%encoding\s+(.*?)(?=\n)//so and return ('ENCODING', $1); # positive look-ahead # $$refINPUT =~ s/^\[//so and return ('LBRACKET', undef); # $$refINPUT =~ s/^\]//so and return ('RBRACKET', undef); $$refINPUT =~ s/^(.)//so and return ($1, $1); # should not be an issue except on error } sub _is_template { my $store = shift; my $id = shift; my $t = $store->tids ($id) or return undef; return $store->is_a ($t, $store->tids (\ TEMPLATE)); } sub _is_ontology { my $store = shift; my $prefixes = shift; my $prefix = shift; #warn "texting prefix '$prefix' on ".Dumper $prefixes; return $prefixes->{$prefix} if $prefixes->{$prefix}; # cache if ($prefix eq 'astma') { # this is one predefined prefix $prefixes->{$prefix} = ASTMA; } elsif ($prefix eq 'xsd') { # this is the other predefined prefix $prefixes->{$prefix} = XSD; } else { my $p = $store->tids ($prefix); if ($p && $store->is_a ($p, $store->tids (\ ONTOLOGY))) { # is the topic an instance of astma:ontology? $prefixes->{$prefix} = $store->toplet ($store->tids ($prefix))->[TM->INDICATORS]->[0] # then take its subject indicator as expanded URI or die "no subject indicator for '$prefix' provided"; # if there is none, complain } } #warn "prefixes now".Dumper $prefixes; return $prefixes->{$prefix}; } sub parse { my $self = shift; $self->YYData->{INPUT} = shift; #warn "parse"; $self->YYData->{INPUT} =~ s/\r/\n/sg; $self->YYData->{INPUT} =~ s/(?YYData->{INPUT} =~ s/ \+{3} /\n/g; # replace _+++_ with \n $self->YYData->{INPUT} =~ s/\+{4}/+++/g; # stuffed ++++ cleanout $self->YYData->{INPUT} =~ s/^\#.*?\n/\n/mg; # # at there start of every line -> gone $self->YYData->{INPUT} =~ s/\s+\#.*?\n/\n/mg; # anything which starts with #, all blanks are ignored $self->YYData->{INPUT} =~ s/\n\n\n+/\n\n/sg; $self->YYData->{INPUT} =~ s/\n\s+\n+/\n\n/sg; # trimm lines with blanks only # we not only capture what is said EXPLICITELY in the map, we also collect implicit knowledge # we could add this immediately into the map at parsing, but it would slow the process down and # it would probably duplicate/complicate things $self->{USER}->{implicits} = { 'isa-thing' => undef, # just let them spring into existence 'isa-scope' => undef, # just let them spring into existence 'subclasses' => undef }; # $self->{USER}->{topic_count} = 0; # $self->{USER}->{templates} = new TM (psis => undef, baseuri => $self->{USER}->{store}->baseuri); $self->{USER}->{prefixes} = {}; eval { $self->YYParse ( yylex => \&_Lexer, yyerror => \&_Error); #, yydebug => 0x01 ); }; if ($@ =~ /^Cancelled/) { warn $@; # de-escalate Cancelling to warning } elsif ($@) { die $@; # otherwise re-raise the exception } #warn "in parse end ".Dumper $self->{USER}->{implicits}; { # resolving implicit stuff my $implicits = $self->{USER}->{implicits}; my $store = $self->{USER}->{store}; { # all super/subclasses foreach my $superclass (keys %{$implicits->{'subclasses'}}) { $store->assert ( map { [ undef, undef, 'is-subclass-of', TM->ASSOC, [ 'superclass', 'subclass' ], [ $superclass, $_ ] ] } keys %{$implicits->{'subclasses'}->{$superclass}}); } } { # all things in isa-things are THINGS, simply add them $store->internalize (map { $_ => undef } keys %{$implicits->{'isa-thing'}}); } { # establishing the scoping topics $store->assert (map { [ undef, undef, 'isa', TM->ASSOC, [ 'class', 'instance' ], [ 'scope', $_ ] ] } keys %{$implicits->{'isa-scope'}}); } $store->externalize ( $store->instances ($store->tids (\ TEMPLATE)) ); # "removing templates now"; } return $self->{USER}->{store}; } #my $f = new TM::AsTMa::Fact; #$f->Run; TM-1.56/support/0000755000175000017500000000000011465717610011653 5ustar rhorhoTM-1.56/support/mkcoveragepod.pl0000644000175000017500000000146011071722111015020 0ustar rhorhouse TM; use constant DL => "\n\n"; my $TMVERSION = shift @ARGV || die "no version provided"; print < =head1 COPYRIGHT AND LICENSE Copyright 200[8] by Robert Barta, Edrrho\@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; EOT TM-1.56/support/mkaxespod.pl0000644000175000017500000000217511071717744014211 0ustar rhorhouse TM; use constant DL => "\n\n"; my $TMVERSION = shift @ARGV || die "no version provided"; print < module offers the method C (and friends) to query assertions in a TM data structure. While there is a generic search specification, it will be too slow. Instead some axes have been implemented specifically. These are listed below. =head1 SEARCH SPECIFICATIONS Automatically generated from TM ($TMVERSION) EOT print "=over".DL; foreach my $k (sort keys %TM::forall_handlers) { my $v = $TM::forall_handlers{$k}; print "=item Code:".($k || '').DL; print $v->{desc}.DL; use Data::Dumper; my @s = split /\n/, Dumper $v->{params}; pop @s; shift @s; print join "\n", @s; print DL } print "=back".DL; print < =head1 COPYRIGHT AND LICENSE Copyright 200[8] by Robert Barta, Edrrho\@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; EOT TM-1.56/bin/0000755000175000017500000000000011465717610010707 5ustar rhorhoTM-1.56/bin/tm0000644000175000017500000013037711012105127011243 0ustar rhorho#!/usr/bin/perl #-- native plugins ------------------------------------------------------------------------- package TM::Workbench::Plugin::Null; use base 'TM::Workbench::Plugin'; sub precedence { return 'p1'; } sub matches { my $self = shift; my $cmd = shift; return $cmd =~ /^$/ } sub execute { my $self = shift; return ""; # do what you can do best: nothing } 1; package TM::Workbench::Plugin::Help; use base 'TM::Workbench::Plugin'; sub precedence { return 'p1'; } sub matches { my $self = shift; my $cmd = shift; return $cmd =~ /^(help|\?)/ } sub execute { my $self = shift; my $cmd = shift; use Pod::Usage; if ($cmd =~ /tau/) { pod2usage(-input => 'TM/Tau.pm', -exitval => 0, -verbose => 2, -exitval => 'NOEXIT'); # print a nice man page, but do not terminate } else { pod2usage(-exitval => 0, -verbose => 2, -exitval => 'NOEXIT'); # print a nice man page, but do not terminate } return; } 1; #-- native mapspheres -------------------------------------------------------------- package MyMapSphere; use TM; use base qw(TM); use Class::Trait ('TM::MapSphere', 'TM::Synchronizable'); sub source_in {}; # nothing to be done here 1; package MyPersistentMapSphere; our $ms; use Data::Dumper; sub new { my $class = shift; # dont care my %opts = @_; #warn "unfiltered new got URL $opts{url}"; (my $path = $opts{url}) =~ s/^tm://; #warn "got path $path"; my $submap = $ms->is_mounted ($path); #warn "map there is ". $submap; die "unknown path '$path' in mapsphere" unless $submap; return $submap; } 1; #------------------------------------------------------------------------------------ package MyMapSphereFilter; use TM::Tau::Filter; use base qw(TM::Tau::Filter); use Class::Trait qw(TM::MapSphere); sub last_mod { my $self = shift; #warn "filtered MyMapSphere last_mod"; die "internal error: lost path to determine modification" unless $self->{_path_to_be}; if (my $submap = $ms->is_mounted ($self->{_path_to_be})) { # if there is alread a map return $submap->last_mod; # then take its last mod } else { return 0; # no map there, make sure content will be loaded, pretend to be oooold } } sub source_in { my $self = shift; #warn "filtered MyMapSphere source in"; $self->{left}->source_in; die "internal error: lost path to mount" unless $self->{_path_to_be}; # just make sure its there $self->mount (delete $self->{_path_to_be}, $self->{left}, 1); # we force it #warn "mount done"; } 1; package MyPersistentMapSphereFilter; our $ms; sub new { my $class = shift; # we do not really care about that one my %opts = @_; #warn "filtered got URL $opts{url}"; (my $path = $opts{url}) =~ s/^tm://; #warn "got path $path (for $ms)"; $ms->{_path_to_be} = $path; # !!! NB: Here I _know_ that I am the only one fiddling around, this is NOT thread-safe!! return $ms; } 1; #----------------------------------------------------------------------------------- package main; use strict; use warnings; use Data::Dumper; use constant HISTORY_SIZE => 500; use constant PROMPT => "tm> "; my %options; # he were collect on the way Getopt options =pod =head1 NAME tm - Topic Map client and work-bench =head1 SYNOPSIS =head2 Invocation of the work-bench tm ... # interactive version using persistent local store tm --mapsphere=file:/tmp/ # using remote store tm --mapsphere=http://host:13131/ # batch version cat commands | tm - # using extensions tm --source '^dns:'=TM::Virtual::DNS --extension .... # providing your own plugins tm --plugin=/some/directory/ --plugin=/some/other/directory/ =head2 Commands within the work-bench # getting help tm> help this command tm> help tm all help on the work-bench tm> help tau help on Tau expressions # reading in commands tm> do execute a history (config) file # listing all loaded plugins tm> plugins: # deploy implementations tm> source // load the package and register it as source implementation tm> filter // load the package and register it as filter implementation # dealing with history tm> history show some past commands tm> ! execute command with nr in history tm> or get previous/next command in the history (if Term::ReadLine is installed) # doing several things in sequence tm> ; ; ... do all commands in a sequence # getting out tm> exit leave the bench tm> quit ditto tm> ^D ditto (Control-d) # making comments tm> # nice weather today is ignored =head1 DESCRIPTION This simple, text-oriented user interface gives access to some Topic Map functions. This program is mainly thought for quick prototyping and testing Topic Maps and/or TM software, not so much to provide eye-candy. There are two modi operandi: =over =item B Whenever you invoke the program with the parameter C<-> then it will expect commands coming from STDIN. It will process them one by one and will then terminate. cat my-commands | tm - =item B If you invoke the program without a parameter tm then you will be welcomed by a command prompt. Type 'help' within this shell to get an overview over available commands. See L for information about the language. =back =head1 OPTIONS Following command line switches are understood by the program: =over =item B (boolean, default: on) If this option is turned on, a history file will be consumed before the interactive loops starts. At the end of the session the history will be updated. See FILES for details on the location. Note: History handling only applies to the interactive mode. Still, nothing can stop you to take a history file (which contains simply lines of commands) and pipe it into this program: cat myhistory | tm - =cut my $history = 1; $options{'history!'} = \$history; =pod =item B (default: undef) This multiple option allows to add new map implementations for resourceable maps. To add, for instance, a virtualized map covering the DNS (domain name service), you would add --source '^dns:'=TM::Virtual::DNS The first value is a regular expression which specifies under which circumstances the processor is supposed to use that extension if it parses a source as part of a Tau expression (L). The other value is the name of the package which is associated with that pattern. The package is 'use'd at startup time, a warning will be issued if that fails. Several such extensions can be provided. There is no order which can be controlled. =cut my %sources = (); $options{'source=s'} = \%sources; =pod =item B (default: undef) This multiple option allows to add new filter implementations. --filter '^stats:'=TM::Tau::Filter::Statistics' =cut my %filters = (); $options{'filter=s'} = \%filters; =pod =item B (default: none means take the installed ones) This multiple option allows to override and specify the directories where plugins are searched for. If you specify one, then B of the default ones will be loaded! =cut my @plugin_dirs = (); $options{'plugin=s'} = \@plugin_dirs; =pod =item B (default: undef) This URL defines where the background map store has to persistently live in which the maps are stored and from which they can be retrieved later. If it is left undefined, then the store will be simulated in memory only. In the local file system case (using a URL like C), all data will be stored in the local file system. If you happen to have the server package L installed, then you may also provide a URL: http://my.machine.org:13131/ In that case all maps would be stored and retrieve from there. =cut my $mapsphere= undef; # 'file:/tmp/'; $options{'mapsphere=s'} = \$mapsphere; =pod =item B (default: C) Controls the file name where the log messages should be written to. This mainly applies to debugging TM components as all error messages will be output directly. =cut my $logfile = 'tm.log'; $options{'logfile=s'} = \$logfile; =pod =item B (default: INFO) The log level can be set to any of the following values: OFF FATAL ERROR WARN INFO DEBUG ALL =cut my $loglevel = 'INFO'; $options{'loglevel=s'} = \$loglevel; =pod =item B ...does hopefully what you would expect. =cut my $help; $options{'help|?|man'} = \$help; =pod =back =head1 FILES The interpreter will look for history files: =begin html 
      $ENV{HOME}/.tm/history
      $ENV{HOME}/.tmhistory
      ./.tmhistory
=end html =begin text $ENV{HOME}/.tm/history $ENV{HOME}/.tmhistory ./.tmhistory =end text =begin man $ENV{HOME}/.tm/history $ENV{HOME}/.tmhistory ./.tmhistory =end man in this order taking only the first it will find. It will only use the last 100 lines. =cut #== here the fun begins ================================================================== #-- consume the command line options ----------------------------------------------------- use Getopt::Long; if (!GetOptions (%options) || $help) { use Pod::Usage; pod2usage(-exitstatus => 0, -verbose => 1); } my ($OUT, $ERR); # my file handles our $log; # others may want to use this as $main::log { use Log::Log4perl qw(:levels); my $layout = Log::Log4perl::Layout::PatternLayout->new ("%d %F %L %c - %m%n"); use Log::Log4perl::Appender::File; my $appender = Log::Log4perl::Appender->new ("Log::Log4perl::Appender::File", filename => $logfile); $appender->layout ($layout); $main::log = Log::Log4perl->get_logger ("tm"); $main::log->add_appender ($appender); eval qq|\$main::log->level(\${$loglevel}});|; } use TM::Tau; $TM::Tau::filters{'^io:stdout$'} = $TM::Tau::filters{'^-$'} = [ 'TM::Serializable::Summary' ]; # every map on stdout should be a summary #-- extensions, loading ------------------------------------------------------------------ foreach my $m (keys %sources) { eval "use $sources{$m}"; if ($@) { warn "cannot load '$sources{$m}', trying to continue"; } else { $TM::Tau::sources{$m} = $sources{$m}; } } foreach my $m (keys %filters) { eval "use $filters{$m}"; if ($@) { warn "cannot load '$filters{$m}', trying to continue"; } else { $TM::Tau::filters{$m} = $filters{$m}; } } #-- figuring out what mapsphere we are going to use ------------------------------------- if (! defined $mapsphere) { # not defined -> here we create a memory-based one $MyPersistentMapSphere::ms = new MyMapSphere (baseuri => 'tm:', url => 'null:'); $MyPersistentMapSphereFilter::ms = new MyMapSphereFilter (baseuri => 'tm:', url => 'null:'); #} elsif ($mapsphere =~ /^file:/) { # $ms = new TM::MapSphere::MLDBM2 (url => $mapsphere); #} elsif ($mapsphere =~ /^http:/) { # eval "use TM::MapSphere::Client;"; # die $@ if $@; # $ms = new TM::MapSphere::Client (url => $mapsphere); } else { $main::log->logdie (scalar __PACKAGE__ . ": unknown URL method '$mapsphere'"); } $TM::Tau::filters{'^tm:/.*'} = 'MyPersistentMapSphereFilter'; $TM::Tau::sources{'^tm:/.*'} = 'MyPersistentMapSphere'; # TODO: XTM? #-- plugins ------------------------------------------------------------------------------ my @plugins = (new TM::Workbench::Plugin::Null, # native plugins are there in any case new TM::Workbench::Plugin::Help, ); if (@plugin_dirs) { push @plugins, map { _load_plugins ($_) } @plugin_dirs; sub _load_plugins { my $dir = shift; my @ps; foreach my $p (glob ("$dir*.pm")) { $p =~ s|.*(TM/.*)|$1|; # keep only the part after TM/ $p =~ s|.pm||; # remove the extension $p =~ s|/|::|g; # package-ify the name $main::log->warn (scalar __PACKAGE__ . ": trying to load plugin '$p'"); eval "use $p"; push @ps, new $p; } return @ps; } } else { use TM::Workbench::Plugin::Tau; my $file = $INC{'TM/Workbench/Plugin/Tau.pm'} or die "cannot find Tau plugin"; # try to find the plugins (my $plugdir = $file) =~ s|Tau.pm||; # construct the directory where this is push @plugins, _load_plugins ($plugdir); } @plugins = sort { $a->precedence cmp $b->precedence } @plugins; # reorder according to precedence level #use Data::Dumper; #$main::log->logwarn ( Dumper \@plugins ); #-- dealing with Ctrl-c ------------------------------------------------------------------ sub interrupt { die "interrupted by user"; } $SIG{INT} = \ &interrupt; #-- see whether we have content on STDIN or not ------------------------------------------ if (defined $ARGV[0] && $ARGV[0] eq '-') { # we are supposed to read something from STDIN $OUT = \*STDOUT; $ERR = \*STDERR; while (<>) { eval { execute_line ($_); # exceptions will cause this to crash, that's it }; last if $@ =~ /^exit/; # the only thing we honor is the 'exit' die $@ if $@; } } else { # otherwise we are in interactive mode use Term::ReadLine; my $term = new Term::ReadLine 'TM Processor'; # $term->MinLine (HISTORY_SIZE); *STDOUT = $term->OUT; unless ($term->Features->{'getHistory'}) { warn "History management not supported by this ReadLine implementation"; undef $history; } $OUT = $term->OUT; $ERR = $term->OUT; load_history ($term) if $history; eval { # wrap it in eval because Ctrl-c may happen at prompt while (defined ($_ = $term->readline(PROMPT))) { next if /^\#/; # ignore line long comments eval { execute_line ($_, $term); # execute one input line }; last if $@ =~ /^exit/; # if someone typed 'exit', the get out of the loop print $ERR $@; } }; # exit either with 'exit', Ctrl-d or Ctrl-c unless ($@ =~ /interrupt/) { # unless the loop was exited via Ctrl-c save_history ($term) if $history; # so save the history print $OUT "\n"; # make a nice prompt } close STDOUT; # close all output to avoid any DESTROY output close STDERR; } #-- Processing Commands --------------------------------------------------------------------- sub execute_line { my $line = shift; my $term = shift; foreach my $cmd (split (/\s*;\s*/, $line)) { # look for ;'s $cmd =~ s/\s+\#\s.*//; # remove trailing comments $cmd =~ s/^\s*//; # remove leading blanks $cmd =~ s/\s*$//; # remove trailing blanks if ($cmd =~ /^(exit|quit)$/) { # user wants to exit? die "exit"; # propagate dieing } elsif ($cmd =~ /^history$/) { # some history listing my $count = 1; print $OUT map { $count++."\t$_" } map { $_."\n" } $term->GetHistory (); } elsif ($cmd =~ /!(\d+)$/) { # recall a certain command my @history = $term->GetHistory (); if (my $line = $history[$1-1]) { print $OUT "$line\n"; execute_line ($line, $term); } else { print $OUT "$1: command not found\n"; } } elsif ($cmd =~ /^plugins:$/) { use Data::Dumper; print $OUT Dumper \@plugins; } elsif (my ($plugin) = grep { $_->matches ($cmd) } @plugins) { # try to find a matching plugin print $OUT $plugin->execute ($cmd); # warn "unfilt ".ref ($MyPersistentMapSphere::ms); # warn " filt ".ref ($MyPersistentMapSphereFilter::ms); # warn "about to exec $cmd"; #%{$MyPersistentMapSphere::ms} = %{$MyPersistentMapSphereFilter::ms}; # make a content-copy of the mapsphere #warn "mounttab of unfiltered: ". Dumper $MyPersistentMapSphere::ms->{mounttab}; } else { die "unknown command '$cmd'"; # or complain if there is none } } } #-- history load/save ------------------------------------------------------------------------ sub load_history { ## without executing it my $term = shift; my $tmhistory; if ( -r ($tmhistory = $ENV{HOME}."/.tm/history")) { } elsif (-r ($tmhistory = $ENV{HOME}."/.tmhistory")) { } elsif (-r ($tmhistory = ".tmhistory")) { } else { return; } ##print $OUT "reading from $tmhistory\n"; eval { use IO::File; my $fh = new IO::File $tmhistory || warn "Could not open '$tmhistory'"; my @l = <$fh>; my $l = scalar @l >= 100 ? 100 : scalar @l; ## only last 100, otherwise eternal growth, a net schlecht foreach my $l (@l[-$l..-1]) { chomp $l; $term->AddHistory ($l); } }; print $OUT $@ ? "Exception: $@" : ""; } sub save_history { my $term = shift; ##print $OUT "checking $ENV{HOME}..." ; my $tmhistory; if (-d $ENV{HOME}."/.tm/") { $tmhistory = $ENV{HOME}."/.tm/history"; } elsif ($ENV{HOME}) { $tmhistory = $ENV{HOME}."/.tmhistory"; } else { $tmhistory = ".tmhistory"; } ##print $OUT "writing to $mqlhistory" ; eval { use IO::File; my $fh = new IO::File ">>$tmhistory" || warn "Cannot open logfile '$tmhistory'"; print $fh map { $_."\n" } $term->GetHistory (); }; print $OUT $@ ? "Exception: $@" : ""; } exit; our $VERSION = "2.00"; our $REVISION = '$Id$'; =pod =head1 AUTHOR INFORMATION Copyright 200[1-68], Robert Barta , All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. http://www.perl.com/perl/misc/Artistic.html =cut __END__ sub ExecuteCommand { $_ = shift; s/^\s*//; ##print $OUT "Executing...$_....\n"; if (/^$/) { # empty line ignore } elsif (/^\#/) { # comment print $OUT "comment\n"; ##-- history --in out ----------------------------------------- } elsif (/^history\s*(([<>])\s*(.*))?/) { eval { if ($2 eq '>') { my $fh = new IO::File ">$3" || warn "Cannot open '$3' for writing"; print $fh map { $_."\n" } grep (!/^history/, $term->GetHistory ()); } elsif ($2 eq '<') { my $fh = new IO::File $3 || warn "Could not open '$3' for reading"; ExecuteLineList (map { chomp; $_ } (<$fh>)); } else { print $OUT join ("\n", $term->GetHistory ()), "\n"; } }; print $OUT $@ ? "Exception: $@" : ""; ##-- scoping ------------------------------------------------- } elsif (/^scope(\s+(.+?)\s*)?$/) { if ($1) { $scope = $2; } else { print $OUT (defined $scope ? $scope : "-- undefined --"),"\n"; } ##-- loading ------------------------------------------------- } elsif (/^load\s+(.+?)\s*$/) { my $expr = $1; eval { $tm = new XTM (tie => new XTM::Virtual (expr => $expr), consistency => $consistency); }; if ($@) { print $OUT "xtm: Exception: $@\n"; } ##-- freezing ------------------------------------------------ } elsif (/^freeze\s*(.+?)\s*$/) { if ($1) { my ($fio, $io); ($io = new IO::File "> $1") && ($fio = new IO::Filter::gzip ($io, "w")) && $fio->print (freeze($tm)) && $fio->close; } else { my $fio; ($fio = new IO::Filter::gzip ($OUT, "w")) && $fio->print (freeze($tm)); } ##-- thawing -------------------------------------------------- } elsif (/^thaw\s+(.+?)\s*$/) { if ($1) { undef $/; my ($fio, $io); ($io = new IO::File $1, 'r') && ($fio = new IO::Filter::gunzip ($io, "r")); my $ice; my $buffer; while ($fio->read ($buffer, 1000)) { $ice .= $buffer; } $fio->close; ($tm) = thaw $ice; } else { print $OUT "xtm: Exception: could not open '$1' for reading"; } ##-- the gory details ------------------------------------------------ } elsif (/^dump/) { print $OUT Dumper $tm; ##-- the gory details ------------------------------------------------ } elsif (/^info/) { print $OUT Dumper $tm->info ('informational')->{informational} if $tm && defined $tm->memory; } elsif (/^warn/) { print $OUT Dumper $tm->info ('warnings')->{warnings} if $tm && defined $tm->memory; } elsif (/^errors/) { print $OUT Dumper $tm->info ('errors')->{errors} if $tm && defined $tm->memory; } elsif (/^stats/) { print $OUT Dumper $tm->info ('statistics')->{statistics} if $tm && defined $tm->memory; ##-- finding ------------------------------------------------- } elsif (/^find\s+topic(\s+(.+?)\s*)?$/ || /^topics$/) { my $query = $2 if $1; eval { my $ts = $tm->topics ($query); my $bns = $tm->baseNames ($ts, [ $scope ]); foreach my $tid (sort { $bns->{$a} cmp $bns->{$b} } keys %$bns) { print $OUT "$tid: $bns->{$tid}\n"; } }; if ($@) { print $OUT "xtm: Exception: $@"; } } elsif (/^find\s+assoc(\s+(.+?)\s*)?$/ || /^assocs$/) { my $query = $2 if $1; eval { my $as = $tm->associations ($query); my $bns = $tm->baseNames ($as, [ $scope ]); foreach my $aid (sort { $bns->{$a} cmp $bns->{$b} } keys %$bns) { print $OUT "$aid: $bns->{$aid}\n"; } }; if ($@) { print $OUT "xtm: Exception: $@"; } } elsif (/^topic\s+(\S+)/) { my $tid = $1; eval { output_topic ($tm->topic ($tid)); }; if ($@) { print $OUT "xtm: Exception: $@"; } } elsif (/^assoc\s+(\S+)/) { my $aid = $1; eval { output_assoc ($tm->association ($aid)); }; if ($@) { print $OUT "xtm: Exception: $@"; } } elsif (/^loglevel(\s+(\d+))?/) { $XTM::Log::loglevel = $2 if $1; print $OUT $XTM::Log::loglevel,"\n"; } elsif (/^merge(\s+(.+))?/) { $consistency->{merge} = [ split (/,/, $2) ] if $2; print $OUT join (",", @{$consistency->{merge}}),"\n"; } elsif (/^duplicate_suppression(\s+(.+))?/) { $consistency->{duplicate_suppression} = [ split (/,/, $2) ] if $2; print $OUT join (",", @{$consistency->{duplicate_suppression}}),"\n"; } elsif (/^follow_maps(\s+(.+))?/) { $consistency->{follow_maps} = [ split (/,/, $2) ] if $2; print $OUT join (",", @{$consistency->{follow_maps}}),"\n"; } elsif (/^exit/ || /^quit/) { save_history(); exit; } elsif (/^help/ || /\?/ || /^command/) { print $OUT " Following commands are currently available: load loading the topic map from the [ Note: files have to be loaded with file:... ] freeze [ ] dumps a compressed image of the map onto . If that is missing, then on STDOUT. Format is that of FreezeThaw, gzipped thaw loads a frozen map topic shows some information about a particular topic assoc shows some information about a particular association find topic finds all topics according to (see XTM::Memory) find topic finds all topics topics finds all topics find assoc finds all assocs according to (see XTM::Memory) find assoc finds all assocs assocs finds all assocs scope [ ] show/set scope merge show/set merging policies (comma separated list, see XTM) duplicate_suppression show/set suppressing policies (comma separated list, see XTM) follow_maps show/set policies for following maps (comma separated list, see XTM) info get some overview information about the map warn find unused topics.... errors find undefined topics... stats show some more statistical information dump dumps out the whole map (can be huge!) history show history history < loading a history from a file history > saving the current history to a file loglevel n set logging level to n exit yes, exit quit ditto You can use command line editing (emacs style) and cursor up/down to browse the history. "; ##-- no clue --------------------------------------------------------- } else { print $OUT "what '$_'?\n" } } sub output_assoc { my $a = shift; # print $OUT Dumper $a; print $OUT "(scoped by ".join (", ", map { $_->href } @{$a->scope->references}). ")\n"; print $OUT "is-a: "; my $type = $a->instanceOf->{reference}->{href} if $a->instanceOf; $type =~ s/^#//; print $OUT " $type\n"; print $OUT "members:\n"; foreach my $m (@{$a->members}) { my $role = $m->roleSpec ? $m->roleSpec->reference->href : "-"; $role =~ s/^\#//; print $OUT " role: $role\n"; print $OUT " players: ".join (", ", map { my $s = $_->href; $s =~ s/^\#//; $s } @{$m->references}). "\n"; } } sub output_topic { my $t = shift; # print $OUT Dumper $t; print $OUT "baseNames:\n"; foreach my $b (@{$t->baseNames}) { print $OUT " ".$b->baseNameString->string, " (scoped by ".join (", ", map { $_->href } @{$b->scope->references}). ")\n"; } print $OUT "is-a:\n"; foreach my $i (@{$t->instanceOfs}) { my $type = $i->{reference}->{href}; $type =~ s/^#//; print $OUT " $type\n"; } print $OUT "occurrences:\n"; foreach my $o (@{$t->occurrences}) { print $OUT " ".($o->resource->isa ('XTM::resourceData') ? $o->resource->data : $o->resource->href); my $type = $o->instanceOf->reference->href; $type =~ s/^#//; print $OUT " (typed: ", $type; print $OUT " ,scoped by ".join (", ", map { $_->href } @{$o->scope->references}). ")\n"; } print $OUT "associations:\n"; foreach my $a (@{$tm->associations ("has-role ".$t->id)}) { print $OUT "as role in ".$a, "\n"; } foreach my $a (@{$tm->associations ("has-member ".$t->id)}) { print $OUT "as member in ".$a, "\n"; } } __END__ select (STDERR); $| = 1; } #-- create/manage pid files ------------------------------------------------------------ use Proc::PID::File; if (Proc::PID::File->running (dir => $cfg->{server}->{piddir})) { $main::log->error_die ("already running, so will terminate now") if Proc::PID::File->running (dir => $cfg->{server}->{piddir}); } $main::log->debug ("PID file created"); #-- install interupt handler ----------------------------------------------------------- foreach my $s (qw (TERM KILL INT PIPE)) { $SIG{$s} = sub { $main::log->info ("received signal '$s', shutting down."); exit; }; } __END__ package main; our $log; our %contexts; 1; package Rhobot; use TM::Virtual; use base qw(TM::Virtual); use TM::Maplet; use TM::Access; our $ontology = q| (is-subclass-of) superclass: server subclass: irc-bot rhobot (irc-bot) bn: rhobot in: written in Perl -- understands ontologies which can be loaded dynamically -- uses AsTMaPath to navigate in (virtual and federated maps) (is-realised-via) abstraction: command realisation: action (understands-command) system: rhobot command: reload reload (command) bn: reload command in: this tells the rhobot to restart -- may include later reloading of configuration (is-realised-via) abstraction: reload realisation: execute-reload execute-reload (action) bn: the execution of a reload command oc (execute) : urn:x-rhobot:reload #-- (understands-command) system: rhobot command: shutdown shutdown (command) bn: shutdown command in: shuts down the rhobot and terminates it -- who would want such a beauty to die? (is-realised-via) abstraction: shutdown realisation: execute-shutdown execute-shutdown (action) bn: the execution of a shutdown command oc (execute) : urn:x-rhobot:shutdown #-- (understands-command) system: rhobot command: rotfl rotfl (command) bn: rolling on the floor laughing (is-realised-via) abstraction: rotfl realisation: execute-rotfl execute-rotfl (action) bn: laughing loud and violently -- scary -- all people are looking in bewilderment # this should actually be a rule: # forall $a [ (understands) ] => # exists $a [ (understands) # system: rhobot # context: $a_context ] # AND # exists [ $a_context (context) ] (understands) system: rhobot context: dyna--a-context dyna--a-context (ontology) bn: dynamically loaded map (inclusive ontology) in: consists of an ontology and other maps -- constructed via tau expression |; sub capabilities { return [ TM::Access::LIVE_IN ]; } sub new { my $class = shift; my $self = $class->SUPER::new (@_); use TM::Materialized::AsTMa; $self->{ontology} = new TM::Materialized::AsTMa (inline => $ontology); $self->{ontology}->sync_in; return bless $self, $class; } sub toplet { my $self = shift; use Data::Dumper; ##warn "rhobot toplet ". Dumper \@_; my @l; foreach (@_) { if (my @t = $self->{ontology}->toplet ($_)) { push @l, @t; } elsif ($main::contexts{$_}) { push @l, new Toplet (id => $_, characteristics => [ [ 'universal-scope', undef, TM::Maplet::KIND_BN, $_ ] ]); } else { push @l, undef; } } return @l; } sub toplets { my $self = shift; return ($self->{ontology}->toplets, keys %main::contexts); } sub maplets { my $self = shift; my $template = shift; my @maplets; push @maplets, $self->{ontology}->maplets ($template); if (ref ($template) eq 'TemplateWildcard') { die "unwilling to conform"; } elsif (ref ($template) eq 'TemplateIPlayer') { die "unwilling to conform"; } elsif (ref ($template) eq 'TemplateIPlayerIRole') { die "unwilling to conform"; } elsif (ref ($template) eq 'TemplateIPlayerType') { die "unwilling to conform"; } elsif (ref ($template) eq 'TemplateIPlayerIRoleType') { if ($template->type eq 'understands' && $template->irole eq 'system' && $template->iplayer eq 'rhobot') { foreach my $ctx (keys %main::contexts) { push @maplets, new Maplet (scope => $TM::PSI::US, type => 'understands', roles => [ 'system', 'context' ], players => [ $template->iplayer, $ctx ]); } } else { } } else { die "unimplementated template"; } return @maplets; } 1; use warnings; use strict; use Data::Dumper; use constant CHANNEL => "#rhobot"; #use constant CHANNEL => "#topicmaps"; use constant NICK => 'rhobot'; use constant RETRY_INTERVAL => 10; # secs use constant MASTER => 'drrho!~rho@CPE-203-45-146-245.qld.bigpond.net.au'; use constant SERVER => 'irc.freenode.net'; use constant PORT => 6667; use constant MAX_RESULTS => 5; my %options; # he were collect on the way Getopt options =pod =head1 NAME rhobot.pl - IRC bot, Topic Map based =head1 SYNOPSIS rhobot.pl ... rhobot.pl --config bot.conf Type 'help' within this shell to get an overview over available commands. =head1 DESCRIPTION TBD =head1 OPTIONS Following command line switches are understood by the program: =over =item B This tells you about the rhobot itself. All other options are ignored, no execution is done. =cut my $help; $options{'help|?|man'} = \$help; =pod =item B (default: C) Name of the configuration file. This file is XML-based, outlining particular aspects of the bot itself (server, channel, ...) as well as containing a list of topic maps which should be understood by the bot. See FILES section. =cut use constant CONFIG_FILE => 'rhobot.conf'; my $config_file = CONFIG_FILE; $options{'config=s'} = \$config_file; =pod =item B (default: none) This specifies the name of the log file. No fancy, except that we are using Log::Log4perl to write to it. =cut my $logfile = 'rhobot.log'; $options{'logfile=s'} = \$logfile; =pod =item B (default: C) If switched on the log file will be Ied, i.e. shown on STDOUT as it is filled. This is if you want to watch what is going on. If not switched on, the rhobot will only write into the log file (which can be Ied separately, of course). =cut my $tail = ''; $options{'tail!'} = \$tail; =pod =item B (default: C) The mode controls how the rhobot gets its commands and where it puts the responses. B: Da hat's was! REDESIGN!!! =over =item batch mode: If switched on, the rhobot will run in test mode: - no connecting to IRC - commands are consumed from STDIN - responses go to STDOUT - master information for all contexts is ignored - all errors go to STDERR =item irc mode: All responses are expected on the configured IRC channel for the configured nick. =item interactive mode: TBD =back =cut my $mode = ''; $options{'mode=s'} = \$mode; =pod =back =head1 FILES =head2 Configuration file The configuration file should look like this: irc.freenode.net:6667 #rhobot nick!~user@host.isp.com rhobot: dns:whatever /dev/null It is consumed at program start and takes effect. All switches, though, have a higher precedence. This is to say, that, for instance a rhobot.pl --logfile rhobot.log will override any settings in the configuration file =head2 Log file This is generated via Log4perl. See the code and the documentation to change the format. This is not configurable at the moment. =head1 ARCHITECTURE TBD =head1 TOPIC MAP Packages TBD =head1 AUTHOR INFORMATION Copyright 200[3], Robert Barta , All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. http://www.perl.com/perl/misc/Artistic.html =cut use Getopt::Long; if (!GetOptions (%options) || $help) { use Pod::Usage; pod2usage(-exitstatus => 0, -verbose => 2); } use XML::Simple; my $config = XMLin ($config_file, keyattr => { context => '+name' }, forcearray => [ 'context' ], contentkey => 'tau'); $logfile ||= $config->{logfile}; { use Log::Log4perl qw(:levels); my $layout = Log::Log4perl::Layout::PatternLayout->new("[%r] %F %L %c - %m%n"); use Log::Log4perl::Appender::File; my $appender = Log::Log4perl::Appender->new("Log::Log4perl::Appender::File", filename => $logfile); $appender->layout($layout); $main::log = Log::Log4perl->get_logger("rhobot"); $main::log->add_appender($appender); } $main::log->info ("startup"); $main::log->info ("consumed config file '$config_file'"); my $nick = $config->{identity}->{nick} || NICK; my $polite = $config->{identity}->{polite} || "yes"; # here we control whether the rhobot has to be address directly as 'rhobot:...' my $channel = $config->{channel} || CHANNEL; my $master = $config->{master} || MASTER; my ($server) = $config->{server} ? $config->{server} =~ /([^:]+)/ : (SERVER); my ($port) = $config->{server} ? $config->{server} =~ /:(\d+)/ : (PORT); ##print Dumper $config; use TM; $TM::schemes{'rhobot:'} = 'Rhobot'; sub _load_ctxs { foreach my $c (keys %{$config->{contexts}->{context}}) { $main::log->warn ("no tau expression for '$c'") && next unless $config->{contexts}->{context}->{$c}->{tau}; eval { $main::contexts{$c}->{map} = new TM (tau => $config->{contexts}->{context}->{$c}->{tau}); $main::contexts{$c}->{master} = $config->{contexts}->{context}->{$c}->{master}; $main::log->debug ("loaded context $c"); }; if ($@) { $main::log->warn ($@); } } } _load_ctxs; # different modes, das stinkt nach redesign if ($mode eq 'batch') { ## warn "Contexts". Dumper \%contexts; while (my $msg = <>) { chomp $msg; _process_msg ($nick, 'drrho!~rho@CPE-203-45-146-245.qld.bigpond.net.au', # who, $msg, sub { my $s = shift; print STDOUT "$s\n"; }, { reload => sub { _load_ctxs; return "ok"; }, shutdown => sub { exit; } }, ); } } elsif ($mode eq 'irc') { # IRC use POE; use POE::Component::IRC; POE::Component::IRC->new ('rhobot'); # make session for the bot POE::Session->new # make session which controls the bot ( _start => sub { # we start our application and tell IRC client what to do first my $kernel = $_[KERNEL]; my $heap = $_[HEAP]; my $session = $_[SESSION]; $kernel->sig('QUIT', '__signal'); $main::log->info ("starting bot...(may take a while as IRC servers are probing)"); $kernel->post( rhobot => register => "all" ); $kernel->post( rhobot => connect => { Nick => $nick, Username => $nick, Ircname => 'POE::Component::IRC rhobot', Server => $server, Port => $port, } ); }, _stop => sub { my $kernel = $_[KERNEL]; $main::log->info ("bot shutdown"); $kernel->yield ("shutdown"); }, # __signal => sub { # my ($kernel, $signal_name) = @_[KERNEL, ARG0]; # $main::log->info ("received signal SIG$signal_name"); # $kernel->post( rhobot => '_stop' ); # $kernel->sig_handled(); # }, irc_001 => sub { # we get a welcome message from the IRC server $main::log->info ("got welcome message, bot should join now..."); $_[KERNEL]->post( rhobot => join => $channel ); }, irc_public => sub { # we got a private message my ( $kernel, $who, $where, $msg ) = @_[ KERNEL, ARG0, ARG1, ARG2 ]; my $channel = $where->[0]; _process_msg ($nick, # nick $who, # partner id $msg, # msg sub { # how to output my $s = shift; $kernel->post( rhobot => privmsg => $channel, $s ); }, { reload => sub { _load_ctxs; return "ok"; }, shutdown => sub { $kernel->post( rhobot => _stop => ''); return "ok"; } }, ); }, irc_disconnected => sub { my ( $kernel ) = @_[ KERNEL, ]; $main::log->info ("disconnected...reconnecting after ".RETRY_INTERVAL." secs"); $kernel->delay( '_start', RETRY_INTERVAL ); }, irc_kick => sub { my ( $kernel, $kickee ) = @_[ KERNEL, ARG2, ]; $main::log->info ("someone kicked $kickee...rejoining after ".RETRY_INTERVAL." secs"); $kernel->delay( '_start', RETRY_INTERVAL ); }, irc_error => sub { my ($error ) = @_[ ARG0, ]; $main::log->error ($error); } ); POE::Session->create ( inline_states => { _start => sub { use POE::Wheel::FollowTail; $_[HEAP]->{wheel} = POE::Wheel::FollowTail->new( Filename => $_[ARG0], InputEvent => 'got_line', ErrorEvent => 'got_error', PollInterval => 5, SeekBack => 1024, ); $_[HEAP]->{first} = 0; }, got_line => sub { print "$_[ARG0]\n" if $_[HEAP]->{first}++ }, got_error => sub { warn "$_[ARG0]\n" }, }, args => [ $logfile ], ) if $tail; # starting endless loop $poe_kernel->run(); } elsif ($mode eq '' || $mode eq 'interactive') { die "interactive not implemented yet"; } else { die "unknown mode '$mode'"; } $main::log->info ("shutdown"); exit 0; sub _process_msg { my $nick = shift; my $who = shift; my $msg = shift; my $out = shift; my $commands = shift; my $pnick = ( split /!/, $who )[0]; my $command; if (($polite eq 'yes' && ((undef, $command) = $msg =~ /^($nick\s*:\s*)(.+)/)) || ($polite eq 'no' && ((undef, $command) = $msg =~ /^($nick\s*:\s*)?(%.+)/))){ if ($command =~ /^help/) { &$out ("$pnick: try '$nick: %rhobot: rhobot -> system \\ understands / ontology'"); } elsif (! (my ($ctx, $tid, $apath) = $command =~ m/%(\w+?)\s*:\s*([\*\d\.\w-]+)\s*(->.*)?/)) { # %google: google -> offers ... &$out ("$pnick: syntax: %context: topic -> ..." ); } elsif (! $main::contexts{$ctx}) { &$out ("$pnick: error unknown context '$ctx'" ); } elsif ($main::contexts{$ctx}->{master} && $main::contexts{$ctx}->{master} ne $who) { &$out ("$pnick: sorry, you are no master for '$ctx'" ); } else { $main::log->debug ("split /$ctx/$tid/". ($apath ? "$apath/" : '' )); my @toplets; eval { @toplets = $tid eq '*' ? $main::contexts{$ctx}->{map}->toplet ($main::contexts{$ctx}->{map}->toplets) : $main::contexts{$ctx}->{map}->toplet ($tid); }; if ($@) { &$out ("$pnick: unwilling/unable to extract topics for '$apath'" ); $main::log->debug ("toplet extraction problem '$@'"); return; } ##warn Dumper \@toplets; use TM::AsTMa::Path; my $ap; eval { $ap = new TM::AsTMa::Path ($apath); }; if ($@) { &$out ("$pnick: parse error in '$apath'" ); $main::log->debug ("found parse error '$@'"); return; } my @res; eval { @res = $ap->eval ($main::contexts{$ctx}->{map}, \@toplets); }; if ($@) { &$out ("$pnick: evaluation error in '$apath': $@" ); $main::log->debug ("eval error '$apath': '$@'"); return; } if (@res == 0) { &$out ("$pnick: " ); } else { foreach my $m (@res[0..MAX_RESULTS-1]) { next unless $m; my $response; use TM::Maplet; if (ref($m) eq 'Toplet') { my @bns = grep ($_->[KIND] == TM::Maplet::KIND_BN && $_->[SCOPE] eq 'universal-scope', @{$m->[CHARS]}); $response = $m->[ID]; $response .= ' \\\\ bn: '.$bns[0]->[VALUE]; my @exe = grep ($_->[KIND] == TM::Maplet::KIND_OC && $_->[TYPE] eq 'execute', @{$m->[CHARS]}); foreach my $e (@exe) { $e->[VALUE] =~ /urn:x-rhobot:(.+)/; my $status; eval { $status = &{$commands->{$1}} if $commands->{$1}; }; if ($@) { $status = $@; last; } $response .= ' \\\\ oc (status): '.$status; } } else { #must be maplet then $response = '('.$m->[TYPE].') ' . ($m->[SCOPE] ne $TM::PSI::US ? '@ ' . $m->[SCOPE] : ''); my $p = $m->players; my $r = $m->roles; for (my $i = 0; $i < @$p; $i++) { $response .= " \\\\ $r->[$i] : $p->[$i] "; } } &$out ("$pnick: $response" ); } &$out ("$pnick: (more results suppressed, limit ".MAX_RESULTS.")" ) if $res[MAX_RESULTS]; } } } } __END__ #-- these are the Modules (operators) we want to use (should go into some config) -------- use TM::Tau::Filter::Statistics; #use TM::Virtual::DNS; #$TM::schemes{'dns:'} = 'TM::Virtual::DNS'; # -- we have to define that - at begin means read AsTMa= from STDIN and that - at the end means # -- to write to STDOUT use TM::Tau; @@@@@@@@@@@@@@@@@@@@ %TM::Tau::STDIN = (module => 'TM::Materialized::AsTMa', url => 'io:stdin'); %TM::Tau::STDOUT = (module => 'TM::Materialized::Memory', url => 'io:stdout'); #-- here remote/local decision will be done for me --------------------------------------- use TM::Tau::Processor; my $tau_proc = new TM::Tau::Processor (BaseURL => $baseurl, AutoList => 1); TM-1.56/lib/0000755000175000017500000000000011465717610010705 5ustar rhorhoTM-1.56/lib/TM/0000755000175000017500000000000011465717610011225 5ustar rhorhoTM-1.56/lib/TM/Axes.pm0000644000175000017500000001213411407361476012465 0ustar rhorhopackage TM::Axes; our $VERSION = '0.2'; =pod =head1 NAME TM::Axes - Topic Maps, Axes for TM::match* =head1 DESCRIPTION The L module offers the method C (and friends) to query assertions in a TM data structure. While there is a generic search specification, it will be too slow. Instead some axes have been implemented specifically. These are listed below. =head1 SEARCH SPECIFICATIONS Automatically generated from TM (1.54) =over =item Code: returns all assertions =item Code:anyid return all assertions where a given toplet appears somehow 'anyid' => 'the toplet' =item Code:aplayer.arole.bplayer.brole.type return all assertions of a given type where a given toplet plays a given role and there exist another given role with another given toplet as player 'bplayer' => 'the player for the brole', 'aplayer' => 'the player toplet for the arole', 'arole' => 'the role toplet (incl subclasses) for the aplayer', 'type' => 'the type of the assertion', 'brole' => 'the other role toplet (incl subclasses)' =item Code:aplayer.arole.brole.type return all assertions of a given type where a given toplet plays a given role and there exist another given role 'aplayer' => 'the player toplet for the arole', 'arole' => 'the role toplet (incl subclasses) for the aplayer', 'type' => 'the type of the assertion', 'brole' => 'the other role toplet (incl subclasses)' =item Code:char.irole deprecated: return all assertions which are characteristics for a given toplet 'irole' => 'the toplet for which characteristics are sought', 'char' => '1' =item Code:char.topic return all assertions which are characteristics for a given toplet 'topic' => 'the toplet for which characteristics are sought', 'char' => '1' =item Code:char.topic.type return all assertions which are a characteristic of a given type for a given topic 'topic' => 'the toplet for which these characteristics are sought', 'char' => '1', 'type' => 'type of characteristic' =item Code:char.type return all assertions which are characteristics for some given type 'char' => '1', 'type' => 'the characteristic type' =item Code:char.type.value return all assertions which are characteristics for some topic of a given value for some given type 'value' => 'the value for which all characteristics are sought', 'char' => '1', 'type' => 'the characteristic type' =item Code:char.value return all assertions which are characteristics for some topic of a given value 'value' => 'the value for which all characteristics are sought', 'char' => '1' =item Code:class.type returns all assertions where there are instances of a given toplet 'class' => 'which toplet should be the class', 'type' => 'isa' =item Code:instance.type returns all assertions where there are classes of a given toplet 'type' => 'isa', 'instance' => 'which toplet should be the instance' =item Code:iplayer return all assertions where a given toplet is a player 'iplayer' => 'the player toplet' =item Code:iplayer.irole return all assertions where a given toplet is a player of a given role 'iplayer' => 'the player toplet', 'irole' => 'the role toplet (incl subclasses)' =item Code:iplayer.irole.type return all assertions of a given type where a given toplet is a player of a given role 'iplayer' => 'the player toplet', 'irole' => 'the role toplet (incl subclasses)', 'type' => 'the type of the assertion' =item Code:iplayer.type return all assertions of a given type where a given toplet is a player 'iplayer' => 'the player toplet', 'type' => 'the type of the assertion' =item Code:irole return all assertions where there is a given role 'irole' => 'the role toplet (incl subclasses)' =item Code:irole.type return all assertions of a given type where there is a given role 'irole' => 'the role toplet (incl subclasses)', 'type' => 'the type of the assertion' =item Code:lid return one particular assertions with a given ID 'lid' => 'the ID of the assertion' =item Code:nochar returns all associations (so no names or occurrences) 'nochar' => '1' =item Code:subclass.type returns all assertions where there are subclasses of a given toplet 'subclass' => 'which toplet should be the superclass', 'type' => 'is-subclass-of' =item Code:superclass.type returns all assertions where there are superclasses of a given toplet 'superclass' => 'which toplet should be the subclass', 'type' => 'is-subclass-of' =item Code:type return all assertions with a given type 'type' => 'the type of the assertion' =back =head1 SEE ALSO L =head1 COPYRIGHT AND LICENSE Copyright 200[8] by Robert Barta, Edrrho@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; TM-1.56/lib/TM/Synchronizable/0000755000175000017500000000000011465717610014217 5ustar rhorhoTM-1.56/lib/TM/Synchronizable/MLDBM.pm0000644000175000017500000000416311066732122015404 0ustar rhorhopackage TM::Synchronizable::MLDBM; use Class::Trait 'base'; use Class::Trait 'TM::Synchronizable'; use Data::Dumper; use MLDBM qw(MLDBM::Sync::SDBM_File Storable); use MLDBM::Sync; use Fcntl qw(:DEFAULT); =pod =head1 NAME TM::Synchronizable::MLDBM - Topic Maps, trait for DBM Storage, synchronous =head1 DESCRIPTION This package subclasses L with a MLDBM store. The methods C and C do the obvious things of copying between the DBM file and the in-memory representation. Only during the synchronisation the DBM file is locked. Otherwise the two copies are independent. The synchronisation is quite performant, certainly faster than using a text representation of the map. =cut sub source_in { my $self = shift; my $url = $self->url; $TM::log->logdie (scalar __PACKAGE__ . ": url '$url' is not pointing to a file") unless $url =~ /^file:/; (my $filename = $self->url) =~ s/^file://; # get rid of this #warn "source in '$filename'"; my %map; my $sync_dbm = tie %map, 'MLDBM::Sync', $filename, O_RDWR|O_CREAT, 0600 or $TM::log->logdie (scalar __PACKAGE__ .": $!"); $sync_dbm->Lock; %{$self} = %{$map{data}}; $sync_dbm->UnLock; } sub source_out { my $self = shift; my $url = $self->url; $TM::log->logdie (scalar __PACKAGE__ . ": url '$url' is not pointing to a file") unless $url =~ /^file:/; (my $filename = $self->url) =~ s/^file://; # get rid of this #warn "source out '$filename'"; my %map; my $sync_dbm = tie %map, 'MLDBM::Sync', $filename, O_CREAT|O_RDWR, 0600 or $TM::log->logdie (scalar __PACKAGE__ .": $!"); $sync_dbm->Lock; $map{data} = $self; $sync_dbm->UnLock; } =pod =head1 SEE ALSO L, L =head1 AUTHOR INFORMATION Copyright 200[68], Robert Barta , All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. http://www.perl.com/perl/misc/Artistic.html =cut our $VERSION = '0.03'; our $REVISION = '$Id$'; 1; __END__ TM-1.56/lib/TM/Synchronizable/MapSphere.pm0000644000175000017500000001651210777176260016453 0ustar rhorhopackage TM::Synchronizable::MapSphere; use strict; use warnings; use TM; use Data::Dumper; use Class::Trait 'base'; use Class::Trait 'TM::ResourceAble'; use TM::MapSphere; #our @REQUIRES = qw(source_in source_out); # provides sync_in/out =pod =head1 NAME TM::Synchronizable::MapSphere - Topic Maps, trait for a syncing a hierarchical TM repository =head1 SYNOPSIS use TM; use base qw(TM); use Class::Trait ('TM::MapSphere', 'TM::Synchronizable::MLDBM' => { exclude => [ "sync_in", "sync_out" ] }, 'TM::Synchronizable::MapSphere'); =head1 DESCRIPTION This trait adds C and C functionality to a map sphere. The point here is that embedded child maps are also synced out or in. =head2 Map Meta Data =head1 INTERFACE =head2 Methods =over =item B I<$ms>->sync_in (I<$path>) A whole subtree of the map repository can be I, i.e. synchronized with contents in an associated resource. If this method is triggered with a particular path, then the map there will be (a) synced in, (b) queried for sub-maps and (c) these sub-maps will be instantiated. Recursively, these submaps will be sync'ed in, etc. All these sub maps will be mounted under this branch of the tree. When a map is instantiated, its implementation package will be extracted from the parent map using a C characteristic. The resource URL will be determined from one of the subject indicators, the base URI will be determined from the subject address of the map topic. If any of these are missing, this particular sub-map is ignored. B: Let us assume that a map has a C C and a resource URL C. It is a materialized map using the XTM driver. If this map is mounted into a root map under C, then the entry will take the form (using AsTMa= 2.0 as notation): foo isa topicmap ~ http://example.org/here.xtm = http://whatever/ implementation: TM::Materialized::XTM @@@ TODO: no path @@@@? =cut use constant MAX_DEPTH => 99; sub sync_in { my $self = shift; my $pref = shift || '/'; # prefix determines from where we would want to start to sync my $depth = shift || MAX_DEPTH; #warn "sync in mapsphere last mod : ".$self->last_mod; #warn "sync in mapsphere mtime : ".$self->mtime; $self->source_in if $pref eq '/' # but only if we start at the top && $self->last_mod < $self->mtime + 1; # and the usual exercise + benefit of doubt _sync_in_children ($self, $self, '/', $pref, $depth - 1); # now we find all children, sync_in them and mount them sub _sync_in_children { my $top = shift; # will be passed through all recursivel leves my $map = shift; # current map whose children we seek my $path = shift; # the current path for mounting my $pref = shift; # the prefix, only under it we seriously do something my $depth = shift; #warn "_sync_in_children $top $map $path $pref ($depth)"; return unless $depth; # if we have reached our limit, we stop foreach my $m ( $map->instances ($map->mids (\ TM::PSI->TOPICMAP)) ) { (my $id = $m) =~ s|.+/(.+)|$1|; # throw away the baseuri stuff #warn "id $id"; my $newpath = $path . "$id/"; # child will have this path #warn "consider $newpath, compare it with $pref"; if ($newpath =~ /^$pref/) { # only if the prefix is matched we seriously do something #warn "--- $newpath within prefix $pref"; my $mid = $map->midlet ($m); # get the topic itself #warn Dumper $mid; my ($url) = @{$mid->[TM->INDICATORS]} or next; # if there is no subject indicator, we could not load it anyway my ($baseuri) = $mid->[TM->ADDRESS] or next; # if there is no subject address, we could not load it anyway my ($implementation) = map { $_->[ TM->PLAYERS ]->[1]->[0] } $map->match (TM->FORALL, char => 1, topic => $m, type => $map->mids (\ TM::MapSphere->IMPLEMENTATION)) or next; my $child; #warn "-- implementation $implementation"; eval { $child = $implementation->new (url => $url, baseuri => $baseuri ); }; $TM::log->logdie (scalar __PACKAGE__ .": cannot instantiate '$implementation' (maybe 'use' it?) for URL '$url' ($@)") if $@; $child->sync_in; #warn "---- synced in"; $top->mount ($newpath => $child, 1); # finally mount this thing into the current, force it in case #warn "-------mounted $newpath"; _sync_in_children ($top, $child, $newpath, $pref, $depth-1); # go down recursively (depth TTL included) #warn "---- back from children"; } } #warn "children done"; } } =pod =item B I<$ms>->sync_out ([ I<$path> ], [ I<$depth> ]) This method syncs out not only the root map sphere object (at least if the resource C is earlier that any change on the map sphere). The method also consults the mount tab to find child maps and will sync them out as well. The optional C parameter controls which subtree should be synced out. It defaults to C. The optional C<$depth> controls how deep the subtree should be followed downwards. Default is C (see the source). =cut sub sync_out { my $self = shift; my $pref = shift || '/'; my $depth = shift || MAX_DEPTH; # warn __PACKAGE__ . "sync_out"; # warn "calling $self source out"; #warn "sync out mapsphere last mod : ".$self->last_mod; #warn "sync out mapsphere mtime : ".$self->mtime; if ( $pref eq '/' && $self->mtime < $self->last_mod) { # there was a change internally #warn "really sync out mapspheric root"; my $mt = delete $self->{mounttab}; # this make sure that only the map is source'd out (MLDBM would take EVERYTHING) $self->source_out if $self->last_mod > $self->mtime; $self->{mounttab} = $mt; # reinstate mount table } my $mt = $self->{mounttab}; foreach my $path (grep ($_ ne '/', keys %$mt)) { # all children (not the root) #warn "--- considering $path for sync_out"; next unless $path =~ /^$pref/; my @segs = $path =~ /(\/)/g; next if scalar @segs > $depth; #warn "--- really chosen $path for sync_out"; $mt->{$path}->sync_out; } } =pod =back =head1 AUTHOR Robert Barta, Edrrho@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright (C) 200[67] by Robert Barta This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.4 or, at your option, any later version of Perl 5 you may have available. =cut our $VERSION = 0.02; our $REVISION = '$Id: MapSphere.pm,v 1.3 2006/11/25 08:46:59 rho Exp $'; 1; __END__ TM-1.56/lib/TM/Synchronizable/Null.pm0000644000175000017500000000035110777176260015473 0ustar rhorhopackage TM::Synchronizable::Null; use Class::Trait 'base'; use Class::Trait qw(TM::Synchronizable); sub source_in { my $self = shift; $self->{_ins}++; } sub source_out { my $self = shift; $self->{_outs}++; } 1; TM-1.56/lib/TM/Serializable.pm0000644000175000017500000001116411402244362014162 0ustar rhorhopackage TM::Serializable; use Class::Trait 'base'; use Class::Trait 'TM::Synchronizable'; =pod =head1 NAME TM::Serializable - Topic Maps, abstract trait for stream (map) based input/output drivers =head1 SYNOPSIS # step 1) you write an input/output driver for a serialized TM format package MyFormat; # provides methods sub deserialize { my $self = shift; # gets current map my $stream = shift; # .... fill the map with content } sub serialize { my $self = shift; # get the map # .... return ... #serialized content } 1; # step 2) construct a subclass of TM using this driver package MapWithMyFormat; use TM; use base qw(TM); use Class::Trait qw(TM::Serializable MyFormat); 1; # step 3) use it in your application my $tm = new MapWithMyFormat (url => 'file:map.myformat'); $tm->sync_in; # uses MyFormat to parse the content from the file =head1 DESCRIPTION This trait implements synchronizable resources using a serialized format. Examples are formats such as AsTMa 1.0, 2.0, LTM, CTM, XTM. The only thing these drivers have to provide are the methods C and C which serialize maps to streams and vice-versa. This trait provides the implementations for C and C triggering C and C, respectively. =head1 INTERFACE =head2 Methods =over =item B Uses the URL attached to the map object to trigger C on the stream content behind the resource. All URLs of L are supported. If the URI is C then content from STDIN is consumed. This content can be consumed more than once (it is buffered internally), so that you can read several times from C getting the same input. If the resource URI is C, then nothing happens. If the resource URI is C, then nothing happens. [Since TM 1.53]: Any additional parameters are passed through to the underlying C method. =cut sub source_in { my $self = shift; my $url = $self->url; #warn "serial source in checking url $url"; return if $url eq 'io:stdout'; # no syncing in from STDOUT return if $url eq 'null:'; # no syncing in from null my $content = _get_content ($url); $self->deserialize ($content, @_); } our $STDIN; # here we store the STDIN content to be able to reuse it later sub _get_content { my $url = shift or $TM::log->logdie (scalar __PACKAGE__ . ": url is empty"); if ($url =~ /^inline:(.*)/s) { return $1; } elsif ($url eq 'io:stdout') { return undef; } elsif ($url eq 'io:stdin') { unless ($STDIN) { local $/; $STDIN = scalar ; } return $STDIN; } else { # some kind of URL? use LWP::Simple; return get($url) || die "unable to load '$url'\n"; } } =pod =item B This method triggers C on the object. The contents will be copied to the resource identified by the URI attached to the object. At the moment, only C URLs and C is supported. If the resource URI is C, nothing happens. If the resource URI is C, nothing happens. If the resource URI is C nothing happens. [Since TM 1.53]: Any additional parameters are passed through to the underlying C method. =cut sub source_out { my $self = shift; my $url = $self->url; return if $url eq 'io:stdin'; # no syncing out to STDIN return if $url eq 'null:'; # no syncing out to null return if $url =~ /^inline:/; # no syncing out to inline my $content = $self->serialize (@_); _put_content ($url, $content); } sub _put_content { my $url = shift; my $s = shift; #warn "put content '$s' to ".$url; if ($url eq 'io:stdin') { # no, I will not do that } elsif ($url eq 'null:') { # we should not be there, but in case, nothing will be written } elsif ($url =~ /^inline:/) { # we should not be there, but in case, nothing will be written } elsif ($url eq 'io:stdout') { print STDOUT $s; } elsif ($url =~ /^file:(.*)/) { # LWP does not support file: PUT? open (F, ">$1") or die "cannot open file '$1' for writing"; print F $s; close F; } else { die "other URL schemes '$url' not yet implemented"; } } =pod =back =head1 SEE ALSO L, L =head1 AUTHOR INFORMATION Copyright 20(0[2-6]|10), Robert Barta , All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. http://www.perl.com/perl/misc/Artistic.html =cut our $VERSION = 0.13; 1; __END__ TM-1.56/lib/TM/PSI.pm0000644000175000017500000002453311420521307012210 0ustar rhorhopackage TM::PSI; =pod =head1 NAME TM::PSI - Topic Maps, PSI (published subject identifiers) =head1 DESCRIPTION This package provides predefined subjects, all of which will be preloaded in B map which is instantiated with the L package hierarchy. When the subjects are defined also their relationship are kept here (example: I). Every such subject is defined by its =over =item B The internal identifier, which does not really mean much. =item B The subject indicator(s), which is ultimately B which identifies any of the subjects here. =back B: For none of the subjects declared here a subject address exists. All concepts are TM-related concepts. The subjects are sorted: =over =item B-related These are the minimal subjects which make a map what it is. Examples are C and its related role (type) C and C, and C and its related roles. =item B-related (XTM things) These are the additional concepts which are mandated by TMDM. =item B-related Here are more concepts which are needed by the AsTMa= language(s), such as C