diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..9bf8ec4 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,12 @@ +*.html -crlf +*.htm -crlf +*.dot -crlf +*.svg -crlf +*.ent -crlf +*.css -crlf +*.dtd -crlf +*.t*xt -crlf +*.xs -crlf +*.xsl -crlf +*.xml -crlf +*.xmlq -crlf diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..009d9f5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +tmp/ +*.dribble +*.fasl +*.dfsl +*.cfsl +*.fas +*.lib +*.o +*.*fsl +*.bak +*~ +bin/ + +#Mac stuff +Icon? +.DS_Store +xml-grammar.lisp diff --git a/LGPLv2.1.txt b/LGPLv2.1.txt new file mode 100644 index 0000000..74bd3b8 --- /dev/null +++ b/LGPLv2.1.txt @@ -0,0 +1,459 @@ + 1: GNU LESSER GENERAL PUBLIC LICENSE + 2: Version 2.1, February 1999 + 3: + 4: Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 5: 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + 6: Everyone is permitted to copy and distribute verbatim copies + 7: of this license document, but changing it is not allowed. + 8: + 9: [This is the first released version of the Lesser GPL. It also counts + 10: as the successor of the GNU Library Public License, version 2, hence + 11: the version number 2.1.] + 12: + 13: Preamble + 14: + 15: The licenses for most software are designed to take away your + 16: freedom to share and change it. By contrast, the GNU General Public + 17: Licenses are intended to guarantee your freedom to share and change + 18: free software--to make sure the software is free for all its users. + 19: + 20: This license, the Lesser General Public License, applies to some + 21: specially designated software packages--typically libraries--of the + 22: Free Software Foundation and other authors who decide to use it. You + 23: can use it too, but we suggest you first think carefully about whether + 24: this license or the ordinary General Public License is the better + 25: strategy to use in any particular case, based on the explanations below. + 26: + 27: When we speak of free software, we are referring to freedom of use, + 28: not price. Our General Public Licenses are designed to make sure that + 29: you have the freedom to distribute copies of free software (and charge + 30: for this service if you wish); that you receive source code or can get + 31: it if you want it; that you can change the software and use pieces of + 32: it in new free programs; and that you are informed that you can do + 33: these things. + 34: + 35: To protect your rights, we need to make restrictions that forbid + 36: distributors to deny you these rights or to ask you to surrender these + 37: rights. These restrictions translate to certain responsibilities for + 38: you if you distribute copies of the library or if you modify it. + 39: + 40: For example, if you distribute copies of the library, whether gratis + 41: or for a fee, you must give the recipients all the rights that we gave + 42: you. You must make sure that they, too, receive or can get the source + 43: code. If you link other code with the library, you must provide + 44: complete object files to the recipients, so that they can relink them + 45: with the library after making changes to the library and recompiling + 46: it. And you must show them these terms so they know their rights. + 47: + 48: We protect your rights with a two-step method: (1) we copyright the + 49: library, and (2) we offer you this license, which gives you legal + 50: permission to copy, distribute and/or modify the library. + 51: + 52: To protect each distributor, we want to make it very clear that + 53: there is no warranty for the free library. Also, if the library is + 54: modified by someone else and passed on, the recipients should know + 55: that what they have is not the original version, so that the original + 56: author's reputation will not be affected by problems that might be + 57: introduced by others. + 58: + 59: Finally, software patents pose a constant threat to the existence of + 60: any free program. We wish to make sure that a company cannot + 61: effectively restrict the users of a free program by obtaining a + 62: restrictive license from a patent holder. Therefore, we insist that + 63: any patent license obtained for a version of the library must be + 64: consistent with the full freedom of use specified in this license. + 65: + 66: Most GNU software, including some libraries, is covered by the + 67: ordinary GNU General Public License. This license, the GNU Lesser + 68: General Public License, applies to certain designated libraries, and + 69: is quite different from the ordinary General Public License. We use + 70: this license for certain libraries in order to permit linking those + 71: libraries into non-free programs. + 72: + 73: When a program is linked with a library, whether statically or using + 74: a shared library, the combination of the two is legally speaking a + 75: combined work, a derivative of the original library. The ordinary + 76: General Public License therefore permits such linking only if the + 77: entire combination fits its criteria of freedom. The Lesser General + 78: Public License permits more lax criteria for linking other code with + 79: the library. + 80: + 81: We call this license the "Lesser" General Public License because it + 82: does Less to protect the user's freedom than the ordinary General + 83: Public License. It also provides other free software developers Less + 84: of an advantage over competing non-free programs. These disadvantages + 85: are the reason we use the ordinary General Public License for many + 86: libraries. However, the Lesser license provides advantages in certain + 87: special circumstances. + 88: + 89: For example, on rare occasions, there may be a special need to + 90: encourage the widest possible use of a certain library, so that it becomes + 91: a de-facto standard. To achieve this, non-free programs must be + 92: allowed to use the library. A more frequent case is that a free + 93: library does the same job as widely used non-free libraries. In this + 94: case, there is little to gain by limiting the free library to free + 95: software only, so we use the Lesser General Public License. + 96: + 97: In other cases, permission to use a particular library in non-free + 98: programs enables a greater number of people to use a large body of + 99: free software. For example, permission to use the GNU C Library in + 100: non-free programs enables many more people to use the whole GNU + 101: operating system, as well as its variant, the GNU/Linux operating + 102: system. + 103: + 104: Although the Lesser General Public License is Less protective of the + 105: users' freedom, it does ensure that the user of a program that is + 106: linked with the Library has the freedom and the wherewithal to run + 107: that program using a modified version of the Library. + 108: + 109: The precise terms and conditions for copying, distribution and + 110: modification follow. Pay close attention to the difference between a + 111: "work based on the library" and a "work that uses the library". The + 112: former contains code derived from the library, whereas the latter must + 113: be combined with the library in order to run. + 114: + 115: GNU LESSER GENERAL PUBLIC LICENSE + 116: TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + 117: + 118: 0. This License Agreement applies to any software library or other + 119: program which contains a notice placed by the copyright holder or + 120: other authorized party saying it may be distributed under the terms of + 121: this Lesser General Public License (also called "this License"). + 122: Each licensee is addressed as "you". + 123: + 124: A "library" means a collection of software functions and/or data + 125: prepared so as to be conveniently linked with application programs + 126: (which use some of those functions and data) to form executables. + 127: + 128: The "Library", below, refers to any such software library or work + 129: which has been distributed under these terms. A "work based on the + 130: Library" means either the Library or any derivative work under + 131: copyright law: that is to say, a work containing the Library or a + 132: portion of it, either verbatim or with modifications and/or translated + 133: straightforwardly into another language. (Hereinafter, translation is + 134: included without limitation in the term "modification".) + 135: + 136: "Source code" for a work means the preferred form of the work for + 137: making modifications to it. For a library, complete source code means + 138: all the source code for all modules it contains, plus any associated + 139: interface definition files, plus the scripts used to control compilation + 140: and installation of the library. + 141: + 142: Activities other than copying, distribution and modification are not + 143: covered by this License; they are outside its scope. The act of + 144: running a program using the Library is not restricted, and output from + 145: such a program is covered only if its contents constitute a work based + 146: on the Library (independent of the use of the Library in a tool for + 147: writing it). Whether that is true depends on what the Library does + 148: and what the program that uses the Library does. + 149: + 150: 1. You may copy and distribute verbatim copies of the Library's + 151: complete source code as you receive it, in any medium, provided that + 152: you conspicuously and appropriately publish on each copy an + 153: appropriate copyright notice and disclaimer of warranty; keep intact + 154: all the notices that refer to this License and to the absence of any + 155: warranty; and distribute a copy of this License along with the + 156: Library. + 157: + 158: You may charge a fee for the physical act of transferring a copy, + 159: and you may at your option offer warranty protection in exchange for a + 160: fee. + 161: + 162: 2. You may modify your copy or copies of the Library or any portion + 163: of it, thus forming a work based on the Library, and copy and + 164: distribute such modifications or work under the terms of Section 1 + 165: above, provided that you also meet all of these conditions: + 166: + 167: a) The modified work must itself be a software library. + 168: + 169: b) You must cause the files modified to carry prominent notices + 170: stating that you changed the files and the date of any change. + 171: + 172: c) You must cause the whole of the work to be licensed at no + 173: charge to all third parties under the terms of this License. + 174: + 175: d) If a facility in the modified Library refers to a function or a + 176: table of data to be supplied by an application program that uses + 177: the facility, other than as an argument passed when the facility + 178: is invoked, then you must make a good faith effort to ensure that, + 179: in the event an application does not supply such function or + 180: table, the facility still operates, and performs whatever part of + 181: its purpose remains meaningful. + 182: + 183: (For example, a function in a library to compute square roots has + 184: a purpose that is entirely well-defined independent of the + 185: application. Therefore, Subsection 2d requires that any + 186: application-supplied function or table used by this function must + 187: be optional: if the application does not supply it, the square + 188: root function must still compute square roots.) + 189: + 190: These requirements apply to the modified work as a whole. If + 191: identifiable sections of that work are not derived from the Library, + 192: and can be reasonably considered independent and separate works in + 193: themselves, then this License, and its terms, do not apply to those + 194: sections when you distribute them as separate works. But when you + 195: distribute the same sections as part of a whole which is a work based + 196: on the Library, the distribution of the whole must be on the terms of + 197: this License, whose permissions for other licensees extend to the + 198: entire whole, and thus to each and every part regardless of who wrote + 199: it. + 200: + 201: Thus, it is not the intent of this section to claim rights or contest + 202: your rights to work written entirely by you; rather, the intent is to + 203: exercise the right to control the distribution of derivative or + 204: collective works based on the Library. + 205: + 206: In addition, mere aggregation of another work not based on the Library + 207: with the Library (or with a work based on the Library) on a volume of + 208: a storage or distribution medium does not bring the other work under + 209: the scope of this License. + 210: + 211: 3. You may opt to apply the terms of the ordinary GNU General Public + 212: License instead of this License to a given copy of the Library. To do + 213: this, you must alter all the notices that refer to this License, so + 214: that they refer to the ordinary GNU General Public License, version 2, + 215: instead of to this License. (If a newer version than version 2 of the + 216: ordinary GNU General Public License has appeared, then you can specify + 217: that version instead if you wish.) Do not make any other change in + 218: these notices. + 219: + 220: Once this change is made in a given copy, it is irreversible for + 221: that copy, so the ordinary GNU General Public License applies to all + 222: subsequent copies and derivative works made from that copy. + 223: + 224: This option is useful when you wish to copy part of the code of + 225: the Library into a program that is not a library. + 226: + 227: 4. You may copy and distribute the Library (or a portion or + 228: derivative of it, under Section 2) in object code or executable form + 229: under the terms of Sections 1 and 2 above provided that you accompany + 230: it with the complete corresponding machine-readable source code, which + 231: must be distributed under the terms of Sections 1 and 2 above on a + 232: medium customarily used for software interchange. + 233: + 234: If distribution of object code is made by offering access to copy + 235: from a designated place, then offering equivalent access to copy the + 236: source code from the same place satisfies the requirement to + 237: distribute the source code, even though third parties are not + 238: compelled to copy the source along with the object code. + 239: + 240: 5. A program that contains no derivative of any portion of the + 241: Library, but is designed to work with the Library by being compiled or + 242: linked with it, is called a "work that uses the Library". Such a + 243: work, in isolation, is not a derivative work of the Library, and + 244: therefore falls outside the scope of this License. + 245: + 246: However, linking a "work that uses the Library" with the Library + 247: creates an executable that is a derivative of the Library (because it + 248: contains portions of the Library), rather than a "work that uses the + 249: library". The executable is therefore covered by this License. + 250: Section 6 states terms for distribution of such executables. + 251: + 252: When a "work that uses the Library" uses material from a header file + 253: that is part of the Library, the object code for the work may be a + 254: derivative work of the Library even though the source code is not. + 255: Whether this is true is especially significant if the work can be + 256: linked without the Library, or if the work is itself a library. The + 257: threshold for this to be true is not precisely defined by law. + 258: + 259: If such an object file uses only numerical parameters, data + 260: structure layouts and accessors, and small macros and small inline + 261: functions (ten lines or less in length), then the use of the object + 262: file is unrestricted, regardless of whether it is legally a derivative + 263: work. (Executables containing this object code plus portions of the + 264: Library will still fall under Section 6.) + 265: + 266: Otherwise, if the work is a derivative of the Library, you may + 267: distribute the object code for the work under the terms of Section 6. + 268: Any executables containing that work also fall under Section 6, + 269: whether or not they are linked directly with the Library itself. + 270: + 271: 6. As an exception to the Sections above, you may also combine or + 272: link a "work that uses the Library" with the Library to produce a + 273: work containing portions of the Library, and distribute that work + 274: under terms of your choice, provided that the terms permit + 275: modification of the work for the customer's own use and reverse + 276: engineering for debugging such modifications. + 277: + 278: You must give prominent notice with each copy of the work that the + 279: Library is used in it and that the Library and its use are covered by + 280: this License. You must supply a copy of this License. If the work + 281: during execution displays copyright notices, you must include the + 282: copyright notice for the Library among them, as well as a reference + 283: directing the user to the copy of this License. Also, you must do one + 284: of these things: + 285: + 286: a) Accompany the work with the complete corresponding + 287: machine-readable source code for the Library including whatever + 288: changes were used in the work (which must be distributed under + 289: Sections 1 and 2 above); and, if the work is an executable linked + 290: with the Library, with the complete machine-readable "work that + 291: uses the Library", as object code and/or source code, so that the + 292: user can modify the Library and then relink to produce a modified + 293: executable containing the modified Library. (It is understood + 294: that the user who changes the contents of definitions files in the + 295: Library will not necessarily be able to recompile the application + 296: to use the modified definitions.) + 297: + 298: b) Use a suitable shared library mechanism for linking with the + 299: Library. A suitable mechanism is one that (1) uses at run time a + 300: copy of the library already present on the user's computer system, + 301: rather than copying library functions into the executable, and (2) + 302: will operate properly with a modified version of the library, if + 303: the user installs one, as long as the modified version is + 304: interface-compatible with the version that the work was made with. + 305: + 306: c) Accompany the work with a written offer, valid for at + 307: least three years, to give the same user the materials + 308: specified in Subsection 6a, above, for a charge no more + 309: than the cost of performing this distribution. + 310: + 311: d) If distribution of the work is made by offering access to copy + 312: from a designated place, offer equivalent access to copy the above + 313: specified materials from the same place. + 314: + 315: e) Verify that the user has already received a copy of these + 316: materials or that you have already sent this user a copy. + 317: + 318: For an executable, the required form of the "work that uses the + 319: Library" must include any data and utility programs needed for + 320: reproducing the executable from it. However, as a special exception, + 321: the materials to be distributed need not include anything that is + 322: normally distributed (in either source or binary form) with the major + 323: components (compiler, kernel, and so on) of the operating system on + 324: which the executable runs, unless that component itself accompanies + 325: the executable. + 326: + 327: It may happen that this requirement contradicts the license + 328: restrictions of other proprietary libraries that do not normally + 329: accompany the operating system. Such a contradiction means you cannot + 330: use both them and the Library together in an executable that you + 331: distribute. + 332: + 333: 7. You may place library facilities that are a work based on the + 334: Library side-by-side in a single library together with other library + 335: facilities not covered by this License, and distribute such a combined + 336: library, provided that the separate distribution of the work based on + 337: the Library and of the other library facilities is otherwise + 338: permitted, and provided that you do these two things: + 339: + 340: a) Accompany the combined library with a copy of the same work + 341: based on the Library, uncombined with any other library + 342: facilities. This must be distributed under the terms of the + 343: Sections above. + 344: + 345: b) Give prominent notice with the combined library of the fact + 346: that part of it is a work based on the Library, and explaining + 347: where to find the accompanying uncombined form of the same work. + 348: + 349: 8. You may not copy, modify, sublicense, link with, or distribute + 350: the Library except as expressly provided under this License. Any + 351: attempt otherwise to copy, modify, sublicense, link with, or + 352: distribute the Library is void, and will automatically terminate your + 353: rights under this License. However, parties who have received copies, + 354: or rights, from you under this License will not have their licenses + 355: terminated so long as such parties remain in full compliance. + 356: + 357: 9. You are not required to accept this License, since you have not + 358: signed it. However, nothing else grants you permission to modify or + 359: distribute the Library or its derivative works. These actions are + 360: prohibited by law if you do not accept this License. Therefore, by + 361: modifying or distributing the Library (or any work based on the + 362: Library), you indicate your acceptance of this License to do so, and + 363: all its terms and conditions for copying, distributing or modifying + 364: the Library or works based on it. + 365: + 366: 10. Each time you redistribute the Library (or any work based on the + 367: Library), the recipient automatically receives a license from the + 368: original licensor to copy, distribute, link with or modify the Library + 369: subject to these terms and conditions. You may not impose any further + 370: restrictions on the recipients' exercise of the rights granted herein. + 371: You are not responsible for enforcing compliance by third parties with + 372: this License. + 373: + 374: 11. If, as a consequence of a court judgment or allegation of patent + 375: infringement or for any other reason (not limited to patent issues), + 376: conditions are imposed on you (whether by court order, agreement or + 377: otherwise) that contradict the conditions of this License, they do not + 378: excuse you from the conditions of this License. If you cannot + 379: distribute so as to satisfy simultaneously your obligations under this + 380: License and any other pertinent obligations, then as a consequence you + 381: may not distribute the Library at all. For example, if a patent + 382: license would not permit royalty-free redistribution of the Library by + 383: all those who receive copies directly or indirectly through you, then + 384: the only way you could satisfy both it and this License would be to + 385: refrain entirely from distribution of the Library. + 386: + 387: If any portion of this section is held invalid or unenforceable under any + 388: particular circumstance, the balance of the section is intended to apply, + 389: and the section as a whole is intended to apply in other circumstances. + 390: + 391: It is not the purpose of this section to induce you to infringe any + 392: patents or other property right claims or to contest validity of any + 393: such claims; this section has the sole purpose of protecting the + 394: integrity of the free software distribution system which is + 395: implemented by public license practices. Many people have made + 396: generous contributions to the wide range of software distributed + 397: through that system in reliance on consistent application of that + 398: system; it is up to the author/donor to decide if he or she is willing + 399: to distribute software through any other system and a licensee cannot + 400: impose that choice. + 401: + 402: This section is intended to make thoroughly clear what is believed to + 403: be a consequence of the rest of this License. + 404: + 405: 12. If the distribution and/or use of the Library is restricted in + 406: certain countries either by patents or by copyrighted interfaces, the + 407: original copyright holder who places the Library under this License may add + 408: an explicit geographical distribution limitation excluding those countries, + 409: so that distribution is permitted only in or among countries not thus + 410: excluded. In such case, this License incorporates the limitation as if + 411: written in the body of this License. + 412: + 413: 13. The Free Software Foundation may publish revised and/or new + 414: versions of the Lesser General Public License from time to time. + 415: Such new versions will be similar in spirit to the present version, + 416: but may differ in detail to address new problems or concerns. + 417: + 418: Each version is given a distinguishing version number. If the Library + 419: specifies a version number of this License which applies to it and + 420: "any later version", you have the option of following the terms and + 421: conditions either of that version or of any later version published by + 422: the Free Software Foundation. If the Library does not specify a + 423: license version number, you may choose any version ever published by + 424: the Free Software Foundation. + 425: + 426: 14. If you wish to incorporate parts of the Library into other free + 427: programs whose distribution conditions are incompatible with these, + 428: write to the author to ask for permission. For software which is + 429: copyrighted by the Free Software Foundation, write to the Free + 430: Software Foundation; we sometimes make exceptions for this. Our + 431: decision will be guided by the two goals of preserving the free status + 432: of all derivatives of our free software and of promoting the sharing + 433: and reuse of software generally. + 434: + 435: NO WARRANTY + 436: + 437: 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO + 438: WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. + 439: EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR + 440: OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY + 441: KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE + 442: IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + 443: PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE + 444: LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME + 445: THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + 446: + 447: 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN + 448: WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY + 449: AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU + 450: FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR + 451: CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE + 452: LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING + 453: RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A + 454: FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF + 455: SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH + 456: DAMAGES. + 457: + 458: END OF TERMS AND CONDITIONS + 459: diff --git a/README b/README new file mode 100644 index 0000000..e047387 --- /dev/null +++ b/README @@ -0,0 +1,5 @@ +Easiest way to build Wilbur (once you are in the listener): + +(require :asdf) +(load "wilbur.asd") +(make-wilbur) diff --git a/schemata/rdf-schema.rdf b/schemata/rdf-schema.rdf new file mode 100644 index 0000000..e170c59 --- /dev/null +++ b/schemata/rdf-schema.rdf @@ -0,0 +1,163 @@ + + + + + + +]> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/schemata/true-rdf-schema.rdf b/schemata/true-rdf-schema.rdf new file mode 100644 index 0000000..84d3248 --- /dev/null +++ b/schemata/true-rdf-schema.rdf @@ -0,0 +1 @@ + ]> \ No newline at end of file diff --git a/src/core/data-sources.lisp b/src/core/data-sources.lisp new file mode 100644 index 0000000..33b9eab --- /dev/null +++ b/src/core/data-sources.lisp @@ -0,0 +1,356 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; data-sources.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Implements the interface to various (loadable) data sources. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; BASIC DATA SOURCE INTERFACE +;;; + +(defmethod db-load ((db db) source + &rest options + &key (error-handling :signal) + (merge-results-p (eq error-handling :signal)) + (clear-temporary-db-p t) + (verbosep *load-verbose*) + (appendp nil) + &allow-other-keys) + ;; returns: SOURCE-DESC, # TRIPLES, ERRORS + (declare (dynamic-extent options)) + (remf options :merge-results-p) + (when verbosep + (format *error-output* "~&Loading RDF: ~S..." (source-locator source)) + (force-output *error-output*)) + (multiple-value-bind (source-desc temporary-db errors) + (apply #'db-load-using-source db source options) + (when (and source-desc temporary-db merge-results-p) + (unless appendp + (db-del-source db (source-desc-url source-desc))) + (db-merge db temporary-db)) + (multiple-value-prog1 (values source-desc + (if (and temporary-db clear-temporary-db-p) + (prog1 (length (db-triples temporary-db)) + (unless (eq db temporary-db) + (db-clear temporary-db))) + temporary-db) + errors) + (when source-desc + (setf (source-desc-load-annotations source-desc) errors)) + (when verbosep + (format *error-output* "~:[done~;failed~].~%" errors))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SOURCE-DESC +;;; + +(defclass source-desc () + ((url + :initarg :url + :initform nil + :reader source-desc-url) + (loaded-from + :initform nil + :accessor source-desc-loaded-from + :initarg :locator + :reader source-locator) + (load-time + :initform nil + :accessor source-desc-load-time) + (load-annotations + :initform nil + :accessor source-desc-load-annotations) + (prefix + :initarg :prefix + :initform nil + :accessor source-desc-prefix))) + +(defmethod print-object ((self source-desc) stream) + (print-unreadable-object (self stream :type t :identity t) + (prin1 (source-desc-url self) stream))) + +(defmethod source-locator :around ((self source-desc)) + (or (call-next-method) + (source-desc-url self))) + +(defmethod db-find-source-desc ((db db) (url string) &optional (createp t)) + (db-find-source-desc db (make-url url) createp)) + +(defmethod db-find-source-desc ((db db) (url url) &optional (createp t)) + (let ((sources (db-source-descs db)) + (url-node (node (url-string url)))) + (or (find url-node sources :key #'source-desc-url) + (find url-node sources :key #'source-desc-loaded-from) + (and createp + (first (push (make-instance 'source-desc :url url-node) + (db-source-descs db))))))) + +(defmethod db-find-source-desc ((db db) (url node) &optional (createp t)) + (db-find-source-desc db (node-uri url) createp)) + +(defmethod db-source-real-url ((db db) (source node)) + (let ((desc (db-find-source-desc db source nil))) + (and desc (source-desc-loaded-from desc)))) + +(defmethod db-source-loaded-p ((db db) source) + (declare (ignore source)) + nil) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; DB-LOAD-USING-SOURCE AND FRIENDS +;;; + +(defmethod db-load-using-source ((db db) (source string) &rest options) + (declare (dynamic-extent options)) + (apply #'db-load-using-source db (db-find-source-desc db source) options)) + +(defmethod db-load-using-source ((db db) (source url) + &rest options) + (declare (dynamic-extent options)) + (apply #'db-load-using-source db (db-find-source-desc db source) options)) + +(defmethod db-load-using-source ((db db) source ; was: source-desc + &rest options + &key (locator nil locatorp) + (error-handling :signal) + &allow-other-keys) + ;; returns: SOURCE-DESC, TEMPORARY DB, ERRORS + (declare (dynamic-extent options)) + (assert (typep source 'source-desc)) + (unless (db-find-source-desc db (source-desc-url source) nil) + (push source (db-source-descs db))) + (let ((errors nil)) + ;; This mimics the possible expansion of WITH-OPEN-FILE + (multiple-value-bind (temporary-db source-node) + (handler-case (let ((abortp t)) + (multiple-value-bind (stream true-url) + (source-open-stream source) + (remf options :error-handling) + (unwind-protect (multiple-value-prog1 + (apply #'source-fill-db source nil stream + (if locatorp + locator + (url-string true-url)) + options) + (setf abortp nil)) + (source-close-stream source stream abortp)))) + (error (e) + (ecase error-handling + (:signal + (cerror "Keep going" e)) + (:collect + (push e errors) + (continue e)) + (:collect-first + (push e errors) + nil)))) + (when (source-desc-prefix source) + (add-namespace (source-desc-prefix source) + (node-uri (if (source-desc-loaded-from source) + (source-desc-url source) + source-node)))) + (unless errors + (setf (source-desc-load-time source) (get-universal-time) + (source-desc-loaded-from source) source-node)) + (values source temporary-db errors)))) + +(defmethod source-fill-db (source db stream locator &rest options) + (declare (ignore source db)) + (apply #'parse-db-from-stream stream locator options)) + +(defmethod source-close-stream (source stream &optional abortp) + (declare (ignore source)) + (close stream :abort abortp)) + +(defmethod source-locator ((source string)) ; assuming it is a URL + source) + +(defmethod source-locator ((source url)) + (url-string source)) + +(defmethod source-open-stream ((source source-desc)) + (source-open-stream (node-uri (or (source-desc-loaded-from source) + (source-desc-url source))))) + +(defmethod source-open-stream ((source string)) + (source-open-stream (make-url source))) + +(defmethod source-open-stream ((source file-url)) + (values (open (url-path source)) source)) + +(defmethod source-open-stream ((source http-url)) + (multiple-value-bind (response true-url) + (http-request source :get) + (values (http-body response) + (or true-url source)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SOURCE-WITH-MODIFICATION +;;; + +(defclass source-with-modification () + ((original-source + :accessor source-original-source) + (original-stream + :initform nil + :accessor source-original-stream))) + +(defmethod initialize-instance :after ((self source-with-modification) + &rest options + &key original-source + &allow-other-keys) + (declare (ignore options)) + (setf (source-original-source self) (if (stringp original-source) + (make-url original-source) + original-source))) + +(defgeneric source-modification (source original-stream)) + +(defmethod source-locator ((source source-with-modification)) + (source-locator (source-original-source source))) + +(defmethod source-open-stream ((source source-with-modification)) + (source-modification source + (setf (source-original-stream source) + (source-open-stream (source-original-source source))))) + +(defmethod source-close-stream :after ((source source-with-modification) stream + &optional abortp) + (declare (ignore stream)) + (source-close-stream (source-original-source source) + (shiftf (source-original-stream source) nil) + abortp)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS COMPUTED-SOURCE +;;; + +(defclass computed-source () + ()) + +(defmethod db-load-using-source ((db db) (source computed-source) + &rest options + &key (locator (source-locator source)) + &allow-other-keys) + (multiple-value-bind (source-desc temp-db errors) + (apply #'source-fill-db source db nil locator options) + (setf (source-desc-load-time source-desc) (get-universal-time) + (source-desc-loaded-from source-desc) (source-desc-url source-desc)) + (values source-desc temp-db errors))) + +(defmethod source-make-temporary-db ((source computed-source) (db db)) + nil) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS STRING-SOURCE +;;; + +(defclass string-source (computed-source) + ((locator + :initarg :locator + :initform nil + :reader source-locator) + (string + :initarg :string + :initform nil + :reader source-string))) + +(defmethod source-fill-db ((source string-source) db stream locator &rest options) + (declare (ignore stream)) + (multiple-value-bind (temporary-db source-node) + (with-input-from-string (stream (source-string source)) + (apply #'parse-db-from-stream stream locator options)) + (values (db-find-source-desc db (make-url (node-uri source-node))) + temporary-db + nil))) diff --git a/src/core/data.lisp b/src/core/data.lisp new file mode 100644 index 0000000..f847fda --- /dev/null +++ b/src/core/data.lisp @@ -0,0 +1,942 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; data.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains functionality for managing "RDF data", namely nodes, +;;; triples, etc. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; TOP-LEVEL NODE API +;;; + +(declaim (special *nodes*)) ; forward reference + +(defun node (thing) + (etypecase thing + (string + (or (find-node *nodes* thing) + (setf (find-node *nodes* thing) (dictionary-make-node *nodes* thing)))) + (null + (dictionary-make-node *nodes* nil)) + (url + (node (url-string thing))) + (node + thing))) + +(defun add-namespace (prefix uri) + (dictionary-add-namespace *nodes* prefix uri)) + +(defun del-namespace (prefix) + (dictionary-remove-namespace *nodes* prefix)) + +(defun namespaces () + (mapcar #'first (dictionary-namespaces *nodes*))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF CONDITION CLASSES +;;; +;;; RDF-ERROR abstract +;;; FEATURE-NOT-SUPPORTED concrete, continuable +;;; ABOUT-AND-ID-BOTH-PRESENT concrete, continuable +;;; ABOUT-AND-NODEID-BOTH-PRESENT concrete, continuable +;;; UNKNOWN-PARSETYPE concrete, continuable +;;; ILLEGAL-CHARACTER-CONTENT concrete, continuable +;;; CONTAINER-REQUIRED concrete, continuable +;;; OUT-OF-SEQUENCE-INDEX concrete +;;; DUPLICATE-NAMESPACE-PREFIX concrete +;;; QUERY-SYNTAX-ERROR concrete +;;; DATATYPE-PARSE-ERROR concrete, continuable +;;; CANNOT-INVERT-DEFAULT-VALUE concrete +;;; UNIDENTIFIED-NODE concrete, continuable +;;; UNSPECIFIED-LOAD-ERROR concrete, continuable +;;; + +(define-condition rdf-error (wilbur-error) + ()) + +(define-condition feature-not-supported (rdf-error) + () + (:default-initargs + :format-control "RDF -- ~S not supported")) + +(define-condition feature-disabled (rdf-error) + () + (:default-initargs + :format-control "RDF -- ~S is disabled")) + +(define-condition about-and-id-both-present (rdf-error) + () + (:default-initargs + :format-control "RDF -- \"about\" and \"ID\" both present")) + +(define-condition about-and-nodeid-both-present (rdf-error) + () + (:default-initargs + :format-control "RDF -- \"about\" and \"nodeID\" both present")) + +(define-condition unknown-parsetype (rdf-error) + () + (:default-initargs + :format-control "RDF -- unknown parsetype ~S")) + +(define-condition illegal-character-content (rdf-error) + () + (:default-initargs + :format-control "RDF -- character content not allowed: ~S")) + +(define-condition container-required (rdf-error) + () + (:default-initargs + :format-control "RDF -- ~S is not a container")) + +(define-condition out-of-sequence-index (rdf-error) + () + (:default-initargs + :format-control "RDF -- index URI ~S allocated out of sequence")) + +(define-condition duplicate-namespace-prefix (rdf-error) + () + (:default-initargs + :format-control "RDF -- duplicate namespace prefix ~S")) + +(define-condition query-syntax-error (rdf-error) + () + (:default-initargs + :format-control "RDF -- no operands for query operator ~A")) + +(define-condition cannot-invert-default-value (rdf-error) + () + (:default-initargs + :format-control "RDF -- cannot invert a default value expression ~S")) + +(define-condition datatype-parse-error (rdf-error) + () + (:default-initargs + :format-control "RDF -- cannot parse datatype literal ~S")) + +(define-condition unidentified-node (rdf-error) + () + (:default-initargs + :format-control "RDF -- externally unidentifiable node ~S")) + +(define-condition unspecified-load-error (rdf-error) + () + (:default-initargs + :format-control "RDF -- load of ~S failed")) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS NODE +;;; + +(defclass node () + ((uri + :initarg :uri + :initform nil + :accessor node-uri) + (name-resolved-p + :initarg :name-resolved-p + :initform t + :accessor node-name-resolved-p))) + +(defmethod print-object ((node node) stream) + (declare (special *nodes*)) ; forward ref. + (let ((uri (node-uri node))) + (cond ((null uri) + (print-unreadable-object (node stream :type t :identity t) + (princ "--" stream))) + ((node-name-resolved-p node) + (multiple-value-bind (name successp) + (find-short-name *nodes* uri) + (format stream "!~:[~S~;~A~]" successp name))) + (t + (format stream "!~A" uri))))) + +(defmethod node-name ((node node)) + (let ((uri (node-uri node))) + (when uri + (if (node-name-resolved-p node) + (find-short-name *nodes* uri) + uri)))) + +(defmethod make-load-form ((node node) &optional env) + (declare (ignore env)) + (if (node-name-resolved-p node) + `(node ,(node-uri node)) + `(unresolved-node ,(node-uri node)))) + +(defvar *index-uris* (make-array 32 :fill-pointer 0 :adjustable t)) + +(defun index-uri (index db) + (let ((delta (- (length *index-uris*) index))) + (cond ((>= delta 0) + (elt *index-uris* (1- index))) + ((= delta -1) + (let ((u (node (rdf-uri (format nil "_~S" index))))) + (vector-push-extend u *index-uris*) + ;; doing path-based reasoning may require this: + (db-new-container-membership-property db u) + u)) + (t + (error 'out-of-sequence-index :thing index))))) + +(defun index-uri-p (node) + (find node *index-uris*)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS DICTIONARY +;;; + +(defclass dictionary () + ((nodes + :initform (make-hash-table :test #'equal) + :initarg :nodes + :reader dictionary-nodes) + (namespaces + :initform nil + :accessor dictionary-namespaces) + (unresolved-nodes + :initform (make-hash-table :test #'equal) + :initarg :unresolved-nodes + :accessor dictionary-unresolved-nodes) + (node-class + :initarg :node-class + :initform 'node + :reader dictionary-node-class))) + +(defmethod initialize-instance :after ((self dictionary) &rest args) + (declare (ignore args)) + (dictionary-add-namespace self "rdf" -rdf-uri-) + (dictionary-add-namespace self "rdfs" -rdfs-uri-) + (dictionary-add-namespace self "owl" -owl-uri-) + (dictionary-add-namespace self "xsd" -xsd-uri-)) + +(defmethod dictionary-add-namespace ((dictionary dictionary) prefix uri) + (declare (special *db*)) ; forward ref. + (let* ((namespaces (dictionary-namespaces dictionary)) + (old-uri (string-dict-get namespaces prefix))) + (cond ((null old-uri) + (setf (dictionary-namespaces dictionary) + (string-dict-add namespaces prefix uri)) + (maphash #'(lambda (name node) + (let ((uri (find-long-name dictionary name))) + (when uri + (remhash name (dictionary-unresolved-nodes dictionary)) + (setf (node-uri node) uri + (node-name-resolved-p node) t + (find-node dictionary uri) node) + (db-node-resolved *db* node name)))) + (dictionary-unresolved-nodes dictionary))) + ((not (string= uri old-uri)) + (setf prefix (string-downcase (symbol-name (gentemp prefix)))) + (setf (dictionary-namespaces dictionary) + (string-dict-add namespaces prefix uri)))) + (when (and (boundp '*db*) *db*) + (db-add-namespace *db* prefix uri)) + prefix)) + +(defmethod dictionary-remove-namespace ((dictionary dictionary) prefix) + (setf (dictionary-namespaces dictionary) + (string-dict-del (dictionary-namespaces dictionary) prefix)) + prefix) + +(defmethod dictionary-rename-namespace ((dictionary dictionary) + old-prefix new-prefix) + (if (string-dict-get (dictionary-namespaces dictionary) new-prefix) + (error 'duplicate-namespace-prefix :thing new-prefix) + (let ((uri (string-dict-get (dictionary-namespaces dictionary) old-prefix))) + (dictionary-remove-namespace dictionary old-prefix) + (dictionary-add-namespace dictionary new-prefix uri) + new-prefix))) + +(defmethod dictionary-make-node ((dictionary dictionary) uri) + (make-instance (dictionary-node-class dictionary) :uri uri)) + +(defmethod find-node ((dictionary dictionary) uri) + (when uri + (gethash uri (dictionary-nodes dictionary)))) + +(defmethod (setf find-node) (node (dictionary dictionary) uri) + (when uri + (setf (gethash uri (dictionary-nodes dictionary)) node))) + +(defmethod find-short-name ((dictionary dictionary) uri &optional use-entities-p) + (reverse-expand-name uri (dictionary-namespaces dictionary) use-entities-p)) + +(defmethod find-long-name ((dictionary dictionary) name) + (expand-name-with-namespace name (dictionary-namespaces dictionary))) + +(defun unresolved-node (name) + (let ((uri (find-long-name *nodes* name))) + (if uri + (node uri) + (let ((unresolved (dictionary-unresolved-nodes *nodes*))) + (or (gethash name unresolved) + (setf (gethash name unresolved) + (make-instance 'node :uri name :name-resolved-p nil))))))) + +(defmethod find-unresolved-nodes ((dictionary dictionary)) + (let ((nodes nil)) + (maphash #'(lambda (uri node) + (declare (ignore uri)) + (push node nodes)) + (dictionary-unresolved-nodes dictionary)) + nodes)) + +(defmethod dictionary-apropos-list ((dictionary dictionary) + (pattern string)) + (let ((nodes nil)) + (maphash #'(lambda (name node) + (when (name-contains-pattern-p name pattern) + (push node nodes))) + (dictionary-nodes dictionary)) + (sort nodes #'string< :key #'node-uri))) + +(defun name-contains-pattern-p (name pattern) + ;; NOTE: This is a naive string search algorithm; I will switch to, say, Boyer-Moore + ;; when I have more time. + (let ((nn (length name)) + (np (length pattern))) + (cond ((= nn np) + (string= name pattern)) + ((> nn np) + (dotimes (i (- nn np -1)) + (when (string= name pattern :start1 i :end1 (+ i np)) + (return-from name-contains-pattern-p t))))))) + +(defvar *nodes* (make-instance 'dictionary)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defun inline-node-reader (stream char) + (declare (ignore char)) + (if (char= (peek-char nil stream t nil t) #\") + (node (read stream t nil t)) + (unresolved-node (read-using *name-reader* stream t)))) + + (defun enable-node-shorthand () + (set-macro-character #\! #'inline-node-reader)) + + (enable-node-shorthand)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS TRIPLE +;;; + +#+:wilbur-triples-as-classes +(defclass triple () + ((subject + :initarg :subject + :reader triple-subject) + (predicate + :initarg :predicate + :reader triple-predicate) + (object + :initarg :object + :accessor triple-object) + (sources + :initarg :sources + :initform nil + :accessor triple-sources))) + +#-:wilbur-triples-as-classes +(defstruct (triple + (:constructor %make-triple (subject predicate object &optional sources))) + subject + predicate + object + sources) + +(defmethod print-object ((triple triple) stream) + (print-unreadable-object (triple stream :type t :identity t) + (format stream "~S ~S ~S" + (triple-subject triple) + (triple-predicate triple) + (triple-object triple)))) + +(defmethod triple= ((triple1 triple) (triple2 triple)) + (and (eq (triple-subject triple1) (triple-subject triple2)) + (eq (triple-predicate triple1) (triple-predicate triple2)) + (eq (triple-object triple1) (triple-object triple2)))) + +(defmethod triple= (thing1 thing2) + (declare (ignore thing1 thing2)) + nil) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS DB +;;; + +(defclass db () + ((triples + :initform nil + :accessor db-triples) + (source-descs + :initform nil + :accessor db-source-descs) + (path-fsas + :initform (make-hash-table :test #'equal) + :reader db-path-fsas) + (literal-class + :initarg :literal-class + :initform 'literal ; could also be STRING or any subclass of LITERAL + :reader db-literal-class))) + +(defmethod initialize-instance :after ((self db) &key (emptyp t) &allow-other-keys) + (unless emptyp + (warn "Schema loading not supported for ~S" self))) + +(defmethod print-object ((db db) stream) + (print-unreadable-object (db stream :type t :identity t) + (format stream "size ~S" (length (db-triples db))))) + +(defmethod db-make-literal ((db db) string &rest options) + (declare (dynamic-extent options)) + (let ((class (db-literal-class db))) + (if (eq class 'string) + string + (apply #'make-instance class :string string :allow-other-keys t options)))) + +(defmethod db-make-triple ((db db) subject predicate object &optional source) + #+:wilbur-triples-as-classes + (make-instance 'triple + :subject subject :predicate predicate :object object + :sources (and source (list source))) + #-:wilbur-triples-as-classes + (%make-triple subject predicate object (and source (list source)))) + +(defmethod db-add-triple ((db db) (triple triple) + &optional (source nil source-supplied-p)) + (let ((sources (triple-sources triple)) + (old-triple (db-find-triple db triple))) + (cond (old-triple + (let ((old-sources (triple-sources old-triple))) + (cond ((or (null sources) + (if source-supplied-p + (member source old-sources) + (subsetp sources old-sources))) + (values old-triple nil nil)) + (t + (unionf (triple-sources old-triple) sources) + (values old-triple nil sources))))) + (t + (push triple (db-triples db)) + (values triple t sources))))) + +(defmethod db-del-triple ((db db) (triple triple) &optional source) + (when source + (let ((new-sources (removef (triple-sources triple) source))) + (when new-sources + (return-from db-del-triple (values triple nil new-sources))))) + (removef (db-triples db) triple) + (values triple t nil)) + +(defmethod db-del-source ((db db) (source node)) + (removef (db-triples db) source :key #'triple-sources :test #'find)) + +(defmethod db-query-by-source ((db db) (source node)) + (remove source (db-triples db) :key #'triple-sources :test-not #'find)) + +(defmethod db-sources ((db db)) + ;; Bogus implementation, for small databases only, included for "completeness" + (let ((sources nil)) + (dolist (triple (db-triples db) sources) + (dolist (source (triple-sources triple)) + (pushnew source sources))))) + +(defmethod db-query ((db db) subject predicate object) + (flet ((matching-triple-p (triple) + (and (eq~ (triple-subject triple) subject) + (eq~ (triple-predicate triple) predicate) + (eq~ (triple-object triple) object)))) + (declare (dynamic-extent #'matching-triple-p)) + (remove-if-not #'matching-triple-p (db-triples db)))) + +(defmethod db-find-triple ((db db) (triple triple)) + (find triple (db-triples db) :test #'triple=)) + +(defmethod db-merge ((to db) (from db) &optional (source nil)) + (dolist (triple (if source + (db-query-by-source from source) + (db-triples from))) + (db-add-triple to triple))) + +(defmethod db-clear ((db db)) + (setf (db-triples db) nil)) + +(defmethod db-count-triples ((db db)) + (length (db-triples db))) + +(defmethod db-new-container-membership-property ((db db) (property node)) + nil) + +(defmethod db-add-namespace ((db db) prefix uri) + (declare (ignore prefix uri)) + nil) + +(defmethod db-node-resolved ((db null) (node node) old-name) + (warn "Node name ~S resolved with NULL database" old-name) + (values node old-name)) + +(defmethod db-node-resolved ((db db) (node node) old-name) + (values node old-name)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS FAST-TEMPORARY-DB +;;; + +(defclass fast-temporary-db (db) + ()) + +(defmethod db-add-triple ((db fast-temporary-db) (triple triple) &optional source) + (declare (ignore source)) + (push triple (db-triples db)) + (values triple t (triple-sources triple))) + +(defmethod db-del-triple ((db fast-temporary-db) (triple triple) &optional source) + (declare (ignore source)) + (removef (db-triples db) triple) + (values triple t nil)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; "CLASS" TRIPLE-INDEX +;;; + +(defun make-triple-index (multiple-components-p) + (declare (ignore multiple-components-p)) + (wilbur-make-hash-table :test #'eq)) + +(eval-when (:load-toplevel :compile-toplevel :execute) + + (defmacro triple-index-get (index &rest components) + (if (rest components) + `(%triple-index-get-double ,index ,@components) + `(%triple-index-get-single ,index ,(first components)))) + + (defmacro triple-index-add (triple index &rest components) + (if (rest components) + `(%triple-index-add-double ,triple ,index ,@components) + `(%triple-index-add-single ,triple ,index ,(first components)))) + + (defmacro triple-index-rem (triple index &rest components) + (if (rest components) + `(%triple-index-rem-double ,triple ,index ,@components) + `(%triple-index-rem-single ,triple ,index ,@components))) + + (defmacro %triple-index-get-single (index component) + (with-temps (i) + `(let ((,i ,index)) + (wilbur-gethash ,component ,i)))) + + (defmacro %triple-index-get-double (index c1 c2) + (with-temps (i sub-index) + `(let* ((,i ,index) + (,sub-index (wilbur-gethash ,c1 ,i))) + (when ,sub-index + (wilbur-gethash ,c2 ,sub-index))))) + + ) + +(defun triple-index-clear (index) + (wilbur-clrhash index)) + +;; (declaim (inline %triple-index-get-single)) + +(defun %triple-index-add-single (triple index component) + (push triple (wilbur-gethash component index))) + +(declaim (inline %triple-index-add-single)) + +(defun %triple-index-rem-single (triple index component) + (removef (wilbur-gethash component index) triple)) + +(declaim (inline %triple-index-rem-single)) + +(defun ensure-sub-index (key1 index) + (or (wilbur-gethash key1 index) + (setf (wilbur-gethash key1 index) (wilbur-make-hash-table :test #'eq :size 30)))) + +(declaim (inline ensure-sub-index)) + +(defun %triple-index-add-double (triple index c1 c2) + (push triple (wilbur-gethash c2 (ensure-sub-index c1 index)))) + +(declaim (inline %triple-index-add-double)) + +(defun %triple-index-rem-double (triple index c1 c2) + (removef (wilbur-gethash c2 (ensure-sub-index c1 index)) triple)) + +(declaim (inline %triple-index-rem-double)) + +(defmacro with-spo-case (((sub pre obj) subject predicate object) + &key spo sp so s po p o all) + `(let ((,sub ,subject) + (,pre ,predicate) + (,obj ,object)) + (cond (,sub (cond (,pre (if ,obj ,spo + ,sp)) + (,obj ,so) + (t ,s))) + (,pre (if ,obj ,po + ,p)) + (,obj ,o) + (t ,all)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS TRIPLE-COLLECTION +;;; + +(defstruct (triple-collection + (:constructor %make-triple-collection ())) + (triples nil) + (index (make-triple-index t))) + +(defun make-triple-collection (&optional triples) + (let ((collection (%make-triple-collection))) + (dolist (triple triples) + (triple-collection-add collection triple)) + collection)) + +(defun triple-collection-find (collection triple) + (find (triple-object triple) + (triple-index-get (triple-collection-index collection) + (triple-predicate triple) + (triple-subject triple)) + :key #'triple-object)) + +(defun triple-collection-add (collection triple) + (or (triple-collection-find collection triple) + (progn (push triple (triple-collection-triples collection)) + (triple-index-add triple (triple-collection-index collection) + (triple-predicate triple) + (triple-subject triple)) + triple))) + +(defun triple-collection-clear (collection) + (triple-index-clear (triple-collection-index collection)) + (setf (triple-collection-triples collection) nil)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS INDEXED-DB +;;; + +(defclass indexed-db (db) + ((index-sp + :initform (make-triple-index t) + :reader db-index-sp) + (index-po + :initform (make-triple-index t) + :reader db-index-po) + (index-s + :initform (make-triple-index nil) + :reader db-index-s) + (index-p + :initform (make-triple-index nil) + :reader db-index-p) + (index-o + :initform (make-triple-index nil) + :reader db-index-o) + (by-source + :initform (make-triple-index nil) + :reader db-by-source)) + (:default-initargs + :rdf-schema-pathname "wilbur:schemata;rdf-schema.rdf" + :populate-with nil)) + +(defmethod initialize-instance :after ((self indexed-db) + &key (emptyp nil) + rdf-schema-pathname + populate-with + &allow-other-keys) + (unless emptyp + (db-load self (make-file-url rdf-schema-pathname) :db self :merge-results-p nil) + (dolist (url populate-with) + (db-load self (make-url url) :db self :merge-results-p nil)))) + +(defmethod db-add-triple ((db indexed-db) (triple triple) &optional source) + (declare (ignore source)) + (multiple-value-bind (actual-triple addedp new-sources) + (call-next-method) + (cond (addedp ; CASE 1: Triple actually added + (let ((s (triple-subject triple)) + (p (triple-predicate triple)) + (o (triple-object triple))) + (triple-index-add triple (db-index-sp db) p s ) + (triple-index-add triple (db-index-po db) p o) + (triple-index-add triple (db-index-s db) s ) + (triple-index-add triple (db-index-p db) p ) + (triple-index-add triple (db-index-o db) o) + (when new-sources + (dolist (source new-sources) + (triple-index-add triple (db-by-source db) source))) + (values triple t new-sources))) + (new-sources ; CASE 2: Only new source(s) added + (dolist (source new-sources) + (triple-index-add triple (db-by-source db) source)) + (values actual-triple nil new-sources)) + (t ; CASE 3: Nothing added, source null + (values actual-triple nil nil))))) + +;;; needs to be fixed vis-a-vis sources +(defmethod db-del-triple ((db indexed-db) (triple triple) &optional source) + (let ((sources (triple-sources triple))) + (multiple-value-bind (triple deletedp new-sources) + (call-next-method) + (cond (deletedp + (let ((s (triple-subject triple)) + (p (triple-predicate triple)) + (o (triple-object triple))) + (triple-index-rem triple (db-index-sp db) p s ) + (triple-index-rem triple (db-index-po db) p o) + (triple-index-rem triple (db-index-s db) s ) + (triple-index-rem triple (db-index-p db) p ) + (triple-index-rem triple (db-index-o db) o) + (dolist (src sources) + (triple-index-rem triple (db-by-source db) src)) + (values triple t nil))) + (t + (triple-index-rem triple (db-by-source db) source) + (values triple nil new-sources)))))) + +(defmethod db-query ((db indexed-db) subject predicate object) + (macrolet ((filter (k tr s) + `(remove ,k ,tr :test-not #'eq :key ,s))) + (with-spo-case ((s p o) subject predicate object) + :spo (filter o (triple-index-get (db-index-sp db) p s) #'triple-object) + :sp (triple-index-get (db-index-sp db) p s) + :so (filter o (triple-index-get (db-index-s db) s) #'triple-object) + :s (triple-index-get (db-index-s db) s) + :po (triple-index-get (db-index-po db) p o) + :p (triple-index-get (db-index-p db) p) + :o (triple-index-get (db-index-o db) o) + :all (db-triples db)))) + +#+:junk +(defmethod db-query ((db indexed-db) subject predicate object) + (macrolet ((filter (k tr s) + `(remove ,k ,tr :test-not #'eq :key ,s))) + (cond (subject + (cond (predicate + (if object + (filter object + (triple-index-get (db-index-sp db) predicate subject) + #'triple-object) + (triple-index-get (db-index-sp db) predicate subject))) + (object + ;; "SO": should we use subject or object index? + (filter object + (triple-index-get (db-index-s db) subject) + #'triple-object)) + (t + (triple-index-get (db-index-s db) subject)))) + (object + (if predicate + (triple-index-get (db-index-po db) predicate object) + (triple-index-get (db-index-o db) object))) + (predicate + (triple-index-get (db-index-p db) predicate)) + (t + (db-triples db))))) + +(defmethod db-find-triple ((db indexed-db) (triple triple)) + (find (triple-object triple) + (triple-index-get (db-index-sp db) + (triple-predicate triple) + (triple-subject triple)) + :key #'triple-object)) + +(defmethod db-del-source ((db indexed-db) (source node)) + (dolist (triple (db-query-by-source db source)) + (db-del-triple db triple source))) + +(defmethod db-query-by-source ((db indexed-db) (source node)) + (triple-index-get (db-by-source db) source)) + +(defmethod db-sources ((db indexed-db)) + (let ((sources nil)) + (wilbur-maphash #'(lambda (key data) + (declare (ignore data)) + (push key sources)) + (db-by-source db)) + sources)) + +(defmethod db-clear :after ((db indexed-db)) + (triple-index-clear (db-index-sp db)) + (triple-index-clear (db-index-po db)) + (triple-index-clear (db-index-s db)) + (triple-index-clear (db-index-p db)) + (triple-index-clear (db-index-o db)) + (triple-index-clear (db-by-source db))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS LOCKED-DB-MIXIN +;;; + +(defclass locked-db-mixin () + ((triple-lock + :initform (make-lock) + :reader db-triple-lock))) + +(defmacro with-triple-lock (db &body body) + `(with-lock ((db-triple-lock ,db)) ,@body)) + +(defmethod db-add-triple :around ((db locked-db-mixin) (triple triple) &optional source) + (declare (ignore source)) + (with-triple-lock db + (call-next-method))) + +(defmethod db-del-triple :around ((db locked-db-mixin) (triple triple) &optional source) + (declare (ignore source)) + (with-triple-lock db + (call-next-method))) + +(defmethod db-merge :around ((to locked-db-mixin) (from db) &optional source) + (declare (ignore source)) + (with-triple-lock to + (call-next-method))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; "TOP-LEVEL" DATA API +;;; + +(defvar *db* nil) ; "current" database + +(defun triple (subject predicate object &optional source) + (db-make-triple *db* subject predicate object source)) + +(defun add-triple (triple) + (db-add-triple *db* triple)) + +(defun del-triple (triple) + (db-del-triple *db* triple nil)) + +(defun query (subject predicate object) + (db-query *db* subject predicate object)) + +(defun reify (triple &key (statement-uri nil) (source nil)) + (db-reify triple *db* statement-uri source)) + +(defun local-properties (node) + (db-node-local-properties *db* node)) + +(defun all-values (frame path) + (db-get-values *db* frame path)) + +(defun add-value (frame path value) + (db-add-triple *db* (db-make-triple *db* frame path value)) + value) + +(defun del-value (frame path &optional value) + (dolist (triple (db-query *db* frame path value)) + (db-del-triple *db* triple nil))) + +(defun value (frame path) + (let ((v (first (db-get-values *db* frame path)))) + (if (typep v 'literal) + (literal-value v) + v))) + +(defun relatedp (source path sink &optional action) + (frames-related-p source path sink *db* action)) diff --git a/src/core/hash-table.lisp b/src/core/hash-table.lisp new file mode 100644 index 0000000..eac438b --- /dev/null +++ b/src/core/hash-table.lisp @@ -0,0 +1,241 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; hash-table.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: A portable interface to hash-tables. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; Some Common Lisp implementations clearly have better hash-table implementations +;;; than others. I tend to like the MCL/OpenMCL implementation, and I particularly +;;; dislike the Allegro implementation. In order to allow alternatives to the Common +;;; Lisp standard hash-tables, we have introduced alternative functions here. +;;; +;;; If the feature :wilbur-own-hashtables is present we use the implementation in this +;;; file; this implementation is based on Ingvar Mattson's public domain package +;;; "genhash" (available from http://www.cliki.net/genhash). +;;; +;;; the general philosophy here is the same as in the hash-table encapsulation of the +;;; BEEF frame system (e.g., beef-gethash, etc.). +;;; + +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; + +(defstruct (wilbur-hash-table + (:conc-name wht-) + (:constructor make-wht (buckets allocated-buckets test))) + buckets + allocated-buckets + (used-buckets 0) + (stored-items 0) + (test nil :read-only t)) + +(defmethod print-object ((self wilbur-hash-table) stream) + (print-unreadable-object (self stream :type t :identity t) + (format stream "~S ~S/~S" + (wht-test self) + (wht-used-buckets self) + (wht-allocated-buckets self)))) + +(defun expand-hash-table (table) + (let* ((new-size (1+ (* 2 (wht-allocated-buckets table)))) + (new-buckets (make-array new-size :initial-element nil)) + (old-data (wht-buckets table))) + (setf (wht-allocated-buckets table) new-size + (wht-used-buckets table) 0 + (wht-buckets table) new-buckets) + (loop for bucket across old-data + do (dolist (chunk bucket) + (setf (wilbur-gethash (car chunk) table) (cdr chunk)))) + table)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; + +(defun wilbur-make-hash-table (&key test + (size 17 #-:wilbur-own-hashtables size-provided-p)) + #-:wilbur-own-hashtables + (if size-provided-p + (make-hash-table :test test :size size) + (make-hash-table :test test)) + #+:wilbur-own-hashtables + (make-wht (make-array size :initial-element nil) size test)) + +(defun wilbur-gethash (key hash-table &optional default) + #-:wilbur-own-hashtables + (gethash key hash-table default) + #+:wilbur-own-hashtables + (let ((bucket (svref (wht-buckets hash-table) + (mod (sxhash key) (wht-allocated-buckets hash-table)))) + (test (wht-test hash-table))) + (dolist (chunk bucket (values default nil)) + (when (funcall test (car chunk) key) + (return (values (cdr chunk) t)))))) + +(defun (setf wilbur-gethash) (value key hash-table &optional default) + #-:wilbur-own-hashtables + (setf (gethash key hash-table default) value) + #+:wilbur-own-hashtables + (declare (ignore default)) + #+:wilbur-own-hashtables + (progn + (when (= (wht-allocated-buckets hash-table) (wht-used-buckets hash-table)) + (expand-hash-table hash-table)) + (let* ((buckets (wht-buckets hash-table)) + (size (wht-allocated-buckets hash-table)) + (bucket-ix (mod (sxhash key) size)) + (bucket (svref buckets bucket-ix)) + check) + (cond ((null (svref buckets bucket-ix)) + (setf (svref buckets bucket-ix) (cons (cons key value) bucket)) + (incf (wht-used-buckets hash-table)) + (incf (wht-stored-items hash-table))) + ((setf check (member key bucket :key #'car :test (wht-test hash-table))) + (setf (cdr (car check)) value)) + (t + (setf (svref buckets bucket-ix) (cons (cons key value) bucket)) + (incf (wht-stored-items hash-table)))) + value))) + +(defun wilbur-remhash (key hash-table) + #-:wilbur-own-hashtables + (remhash key hash-table) + #+:wilbur-own-hashtables + (progn + (when (wilbur-gethash key hash-table nil) + (let* ((buckets (wht-buckets hash-table)) + (bucket-ix (mod (sxhash key) (wht-allocated-buckets hash-table))) + (bucket (svref buckets bucket-ix))) + (setf (svref buckets bucket-ix) + (delete key bucket :test (wht-test hash-table) :key 'car)) + (unless (svref buckets bucket-ix) + (decf (wht-used-buckets hash-table))) + (decf (wht-stored-items hash-table)))) + t)) + +(defun wilbur-clrhash (hash-table) + #-:wilbur-own-hashtables + (clrhash hash-table) + #+:wilbur-own-hashtables + (progn + (setf (wht-used-buckets hash-table) 0) + (loop for ix from 0 below (wht-allocated-buckets hash-table) + do (setf (svref (wht-buckets hash-table) ix) nil)) + hash-table)) + +(defun wilbur-hash-table-count (hash-table) + #-:wilbur-own-hashtables + (hash-table-count hash-table) + #+:wilbur-own-hashtables + (wht-stored-items hash-table)) + +(defun wilbur-hash-table-size (hash-table) + #-:wilbur-own-hashtables + (hash-table-size hash-table) + #+:wilbur-own-hashtables + (wht-used-buckets hash-table)) + +(defun wilbur-maphash (function hash-table) + #-:wilbur-own-hashtables + (maphash function hash-table) + #+:wilbur-own-hashtables + (let ((buckets (wht-buckets hash-table))) + (loop for bucket across buckets + do (dolist (chunk bucket) + (funcall function (car chunk) (cdr chunk)))))) + +#-:wilbur-own-hashtables +(declaim (inline wilbur-make-hash-table + wilbur-gethash + (setf wilbur-gethash) + wilbur-remhash + wilbur-clrhash + wilbur-hash-table-count + wilbur-hash-table-size + wilbur-maphash)) diff --git a/src/core/http.lisp b/src/core/http.lisp new file mode 100644 index 0000000..a140391 --- /dev/null +++ b/src/core/http.lisp @@ -0,0 +1,981 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; http.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This is a simple implementation of an HTTP client, conditionalized for +;;; several platforms and environments. OK, so it is somewhat braindead, but at least +;;; it works. Note: We currently support MCL, OpenMCL and Allegro. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS URL +;;; CLASS HTTP-URL +;;; CLASS FILE-URL +;;; CLASS URN +;;; CLASS TEL-URL +;;; CLASS MAILTO-URL +;;; CLASS UNKNOWN-SCHEME-URL +;;; + +(defclass url () + ((string + :initform nil + :accessor url-string) + (path + :initarg :path + :reader url-path))) + +(defmethod print-object ((url url) stream) + (print-unreadable-object (url stream :type t) + (prin1 (url-string url) stream))) + +(defclass http-url (url) + ((host + :initarg :host + :reader url-host) + (port + :initarg :port + :initform nil + :reader url-port))) + +(defmethod initialize-instance :after ((url http-url) &rest initargs) + (declare (ignore initargs)) + (let ((port (url-port url))) + (setf (url-string url) + (format nil "http://~A~@[:~S~]~@[~A~]" + (url-host url) + (and port (not (= port 80)) port) + (url-path url))))) + +(defclass file-url (url) + ()) + +(defmethod initialize-instance :after ((url file-url) &rest initargs) + (declare (ignore initargs)) + (setf (url-string url) (format nil "file://~A" (namestring (url-path url))))) + +(defclass urn (url) + ()) + +(defmethod initialize-instance :after ((url urn) &rest initargs) + (declare (ignore initargs)) + (setf (url-string url) (format nil "urn:~A" (url-path url)))) + +(defclass tel-url (url) + ((number + :initarg :number + :reader url-number) + (plusp + :initarg :plusp + :initform nil + :reader url-plus-p))) + +(defmethod initialize-instance :after ((url tel-url) &rest initargs) + (declare (ignore initargs)) + (setf (url-string url) (format nil "tel:~:[~;+~]~A" (url-plus-p url) (url-number url)))) + +(defclass mailto-url (url) + ()) + +(defmethod initialize-instance :after ((url mailto-url) &rest initargs) + (declare (ignore initargs)) + (setf (url-string url) (format nil "mailto:~A" (url-path url)))) + +(defclass unknown-scheme-url (url) + ((scheme + :initarg :scheme + :reader url-scheme))) + +(defmethod initialize-instance :after ((url unknown-scheme-url) &rest initargs) + (declare (ignore initargs)) + (setf (url-string url) (format nil "~A:~A" (url-scheme url) (url-path url)))) + +(defvar *url-scheme->class* + '(:http http-url + :file file-url + :urn urn + :tel tel-url + :mailto mailto-url)) + +(defun make-url (string) + (multiple-value-bind (scheme args) + (parse-url string) + (apply #'make-instance (getf *url-scheme->class* scheme 'unknown-scheme-url) args))) + +(defun make-relative-url-string (string base) + (let ((ns (length string)) + (nb (length base)) + (i (position #\/ base :from-end t))) + (cond ((and (> ns nb) + (char= (char string nb) #\#) + (string= string base :end1 nb)) + (subseq string nb)) + ((and i + (> ns (1+ i)) + (string= string base :end1 (1+ i) :end2 (1+ i))) + (subseq string (1+ i))) + (t + string)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HTTP CONDITIONS +;;; + +(define-condition http-error (wilbur-error) + ((thing + :initarg :thing + :reader http-error-thing)) + (:default-initargs + :format-control "HTTP --- ~A") + (:report (lambda (c s) + (funcall #'report-http-error c s)))) + +(define-condition http-bad-response (http-error) + ((got + :initform nil + :initarg :got + :reader http-error-got)) + (:default-initargs + :format-control "HTTP --- Expected ~A, got ~A")) + +(define-condition http-bad-redirect (http-bad-response) + () + (:default-initargs + :format-control "HTTP --- ~A header not found")) + +(define-condition http-not-found (http-error) + () + (:default-initargs + :format-control "HTTP --- Entity ~A not found")) + +(define-condition http-too-many-redirects (http-error) + () + (:default-initargs + :format-control "HTTP --- Too many redirects: last was ~A")) + +(define-condition http-incomplete-entity (http-error) + () + (:default-initargs + :format-control "HTTP --- Incomplete entity: expected ~A more bytes")) + +(define-condition http-bad-request (http-error) + () + (:default-initargs + :format-control "HTTP --- Bad request")) + +(define-condition http-server-error (http-error) + () + (:default-initargs + :format-control "HTTP --- Server error")) + +(define-condition http-unsupported-status (http-error) + () + (:default-initargs + :format-control "HTTP --- Unsupported status code ~S")) + +(defmethod report-http-error ((condition http-error) stream) + (apply #'format stream (simple-condition-format-control condition) + (http-error-thing condition) (simple-condition-format-arguments condition))) + +(defmethod report-http-error ((condition http-bad-response) stream) + (format stream (simple-condition-format-control condition) + (http-error-thing condition) (http-error-got condition))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LOW-LEVEL HTTP STREAM GENERIC FUNCTIONS +;;; + +(defgeneric open-http-stream (url proxy)) + +(defgeneric make-http-body-stream (socket-stream)) + +(defgeneric http-stream-character-count (stream)) + +(defgeneric (setf http-stream-character-count) (new-value stream)) + +(defgeneric http-stream-enable-input-chunking (stream)) + +(defgeneric http-stream-disable-input-chunking (stream)) + +(defgeneric http-stream-chunked-p (http-stream)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HIGH-LEVEL HTTP REQUEST GENERIC FUNCTIONS +;;; + +(defgeneric http-request (url method &key proxy accept)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS HTTP-MESSAGE +;;; + +(defclass http-message () + ((status + :initarg :status + :reader http-status) + (version + :initarg :version + :reader http-version) + (headers + :initarg :headers + :initform nil + :accessor http-headers) + (request-time + :initarg :request-time + :initform (get-universal-time) + :reader http-request-time) + (response-time + :initform (get-universal-time) + :reader http-response-time) + (url + :initform nil + :initarg :url + :reader http-url) + (body + :initarg :body + :initform nil + :reader http-body) + #+:http-using-aserve + (native-request + :initarg :request + :initform nil + :reader http-native-request))) + +#+(and :excl :http-using-aserve) +(defun finalize-http-message (message) + (let ((request (http-native-request message))) + (when request + (net.aserve.client:client-request-close request)))) + +#+(and :excl :http-using-aserve) +(defmethod initialize-instance :after ((self http-message) &rest args) + (declare (ignore args)) + (schedule-finalization self #'finalize-http-message)) + +(defmethod print-object ((self http-message) stream) + (print-unreadable-object (self stream :identity t :type t) + (prin1 (http-status self) stream))) + +(defmethod get-header ((message http-message) (header string)) + (get-header (http-headers message) header)) + +(defmethod get-header ((headers list) (header string)) + #-:http-using-aserve + (string-dict-get headers header) + #+:http-using-aserve + (cdr (assoc (intern (string-upcase header) :keyword) headers))) + +(defmethod add-header ((headers list) (header string) value) + (string-dict-add headers header value)) + +(defun infer-character-count (headers) + (parse-integer (get-header headers "Content-Length") :junk-allowed t)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HTTP CLIENT API +;;; + +#+(and :realmcl (not :http-using-aserve)) +(defmethod http-request ((url http-url) method + &key (proxy (find-http-proxy)) + (accept "application/rdf+xml, application/xml, text/xml")) + (let ((time (get-universal-time))) + (with-open-stream (input (open-http-stream url proxy)) + (multiple-value-bind (status version headers) + (http-get-headers input url + (ecase method (:get "GET") (:head "HEAD")) + accept) + (make-instance 'http-message + :status status :version version :headers headers :request-time time :url url + :body (and (eq method :get) + (let ((chunkedp + (string= (get-header headers "Transfer-Encoding") "chunked")) + (stream (make-http-body-stream input))) + (if chunkedp + (http-stream-enable-input-chunking stream) + (setf (http-stream-character-count stream) + (infer-character-count headers))) + stream))))))) + +#+(and :openmcl (not :http-using-aserve)) +(defmethod http-request ((url http-url) method + &key (proxy (find-http-proxy)) + (accept + "application/rdf+xml, application/xml, text/xml, */*")) + (let ((time (get-universal-time))) + (multiple-value-bind (status version headers body) + (make-curl-http-request method url proxy accept) + (when (eq method :head) + (close (shiftf body nil))) + (make-instance 'http-message + :status status :version version :headers headers :request-time time :url url + :body body)))) + +#+:http-using-aserve +(defmethod http-request ((url http-url) method + &key (proxy (find-http-proxy)) + (accept "application/rdf+xml")) + (let* ((time (get-universal-time)) + (request + (net.aserve.client:make-http-client-request (url-string url) + :method method + :accept accept :proxy proxy))) + (net.aserve.client:read-client-response-headers request) + (make-instance 'http-message + :status (net.aserve.client:client-request-response-code request) + :version nil + :headers (net.aserve.client:client-request-headers request) + :request-time time + :url url + :body (net.aserve.client:client-request-socket request)))) + +#+(and :openmcl (not :http-using-aserve)) +(defun make-curl-http-request (method url proxy accept) + (declare (special *http-parse-buffers*)) + (let* ((input (simple-external-process "curl" + "-s" + (and proxy "-x") proxy + "--header" (format nil "Accept: ~A" accept) + (ecase method + (:get "-i") + (:head "--head")) + (strip-trailing-hash (url-string url))))) + (multiple-value-bind (status version headers) + (with-resource-from-pool (parse-buffer *http-parse-buffers*) + (read-headers-into-pb parse-buffer input) + (compute-response parse-buffer)) + (values status version headers input)))) + +(defconstant -new-line-string- (concatenate 'string (list #\Return #\Linefeed))) + +(defun make-http-request (method url-path url-host accept) + (format nil "~@:(~A~) ~A HTTP/1.1~A~ + Host: ~A~A~ + Accept: ~A~A~ + Connection: close~A~A" + method (strip-trailing-hash url-path) -new-line-string- + url-host -new-line-string- + accept -new-line-string- -new-line-string- -new-line-string-)) + +(defun http-get-headers (input url operation accept) + (declare (special *http-parse-buffers*)) + (write-sequence (make-http-request operation (url-path url) (url-host url) accept) + input) + (force-output input) + (with-resource-from-pool (parse-buffer *http-parse-buffers*) + (read-headers-into-pb parse-buffer input) + (compute-response parse-buffer))) + +(defun http-connection-reusable-p (headers) + (not (string= "close" (get-header headers "Connection")))) + +(defun strip-trailing-hash (string) + (let ((i (1- (length string)))) + (if (char= (char string i) #\#) + (subseq string 0 i) + string))) + +(defun add-trailing-hash (string) + (if (ends-in-hash-p string) + string + (concatenate 'string string "#"))) + +(defparameter *http-max-redirects* 5) ; see RFC 2616 + +(defmethod http-request :around ((url http-url) method &rest args) + (declare (dynamic-extent args)) + (let ((true-url nil)) + (dotimes (i *http-max-redirects*) + (let* ((response (apply #'call-next-method url method args)) + (status (http-status response))) + (case status + ;; OK + (200 (return-from http-request (values response true-url))) + ;; Moved Permanently, Found, See Other + ((301 302 303) + (let ((location (get-header response "Location"))) + (if (null location) + (error 'http-bad-redirect :thing "Location") + (let ((stream (http-body response))) + (when stream + (close stream)) + (setf url (make-url (strip-trailing-hash location))) + (when (= status 303) + (setf true-url url)))))) + ;; Bad Request + (400 (error 'http-bad-request)) + ;; Not Found + (404 (error 'http-not-found :thing (url-string url))) + ;; Internal Server Error + (500 (error 'http-server-error)) + ;; something else... + (t (error 'http-unsupported-status :thing (http-status response)))))) + (error 'http-too-many-redirects :thing url))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; FAST HTTP HEADER PARSING +;;; + +(defparameter *http-parse-buffer-size* 4096) + +(defparameter *http-expected-headers* 20) + +(defstruct (http-response-parse-buffer (:conc-name pb-)) + (buf (make-string *http-parse-buffer-size*)) + (left-bounds (make-array *http-expected-headers*)) + (right-bounds (make-array *http-expected-headers*)) + seen-headers) + +(defun clear-pb (pb) + (setf (pb-seen-headers pb) 0)) + +(define-resource-pool *http-parse-buffers* + #'make-http-response-parse-buffer #'clear-pb) + +(defun stretch-pb-buf (pb delta) + (let* ((old (pb-buf pb)) + (new (make-string (+ (length old) delta)))) + (setf (substring new 0) old + (pb-buf pb) new))) + +(defun stretch-pb-headers (pb delta) + (let* ((old-left (pb-left-bounds pb)) + (old-right (pb-right-bounds pb)) + (len (+ (length old-left) delta)) + (new-left (make-array len)) + (new-right (make-array len))) + (setf (subseq new-left 0) old-left + (subseq new-right 0) old-right + (pb-left-bounds pb) new-left + (pb-right-bounds pb) new-right))) + +(defparameter *http-parsepuf-buffer-default-delta* 2048) + +(defparameter *http-parsebuf-headers-default-delta* 20) + +(defun read-headers-into-pb (pb stream) + (let ((len (length (pb-buf pb))) + (max-lines (length (pb-left-bounds pb)))) + (flet ((push-char (char index) + (when (>= index len) + (stretch-pb-buf pb *http-parsepuf-buffer-default-delta*) + (incf len *http-parsepuf-buffer-default-delta*)) + (setf (char (pb-buf pb) index) char)) + (push-left-bound (pos index) + (when (>= index max-lines) + (stretch-pb-headers pb *http-parsebuf-headers-default-delta*) + (incf max-lines *http-parsebuf-headers-default-delta*)) + (setf (svref (pb-left-bounds pb) index) pos)) + (push-right-bound (pos index) + (setf (svref (pb-right-bounds pb) index) pos))) + (declare (inline push-char push-left-bound push-right-bound)) + (loop with state = :want-cr + with bounds-index = 0 + initially (push-left-bound 0 0) + for index from 0 + do (let ((ch (read-char stream nil nil))) + (cond ((null ch) + (error 'http-bad-response :thing state :got :eof)) + (t + (push-char ch index) + (ecase state + (:want-cr + (when (eql #\Return ch) + (setf state :need-lf) + (push-right-bound index bounds-index) + (incf bounds-index))) + (:need-lf + (unless (eql #\Linefeed ch) + (error 'http-bad-response :thing #\Linefeed :got ch)) + (setf state :maybe-end)) + (:maybe-end + (push-left-bound index bounds-index) + (setf state (if (eql #\Return ch) :end :want-cr))) + (:end + (unless (eql #\Linefeed ch) + (error 'http-bad-response :thing #\Linefeed :got ch)) + (setf (pb-seen-headers pb) bounds-index) + (return)))))))))) + +(defun compute-response (pb) + (let ((buf (pb-buf pb))) + (declare (type string buf)) + (flet ((parse-response-line (start end) + (declare (ignore end)) + (let (version) + (cond ((string= buf "HTTP/1.0" :start1 start :end1 (+ start 8)) + (setf version :http/1.0)) + ((string= buf "HTTP/1.1" :start1 start :end1 (+ start 8)) + (setf version :http/1.1)) + (t (error 'http-bad-response :thing "HTTP/1.0 or HTTP/1.1" + :got (substring buf start (+ start 8))))) + (values (parse-integer buf :start 9 :end 12 :radix 10) version))) + (parse-header-line (start end) + (multiple-value-bind (header index) + (collect-to-char #\: buf :start start :end end) + (if (not index) + (error 'http-bad-response :thing #\:) + (let ((value-start (position #\Space buf + :start (1+ index) :end end + :test-not #'char=))) + (values header (substring buf value-start end))))))) + (declare (inline parse-response-line parse-header-line)) + (let ((left (pb-left-bounds pb)) + (right (pb-right-bounds pb))) + (multiple-value-bind (response-code protocol-version) + (parse-response-line (svref left 0) (svref right 0)) + (do ((index 1 (1+ index)) + (headers nil) + (line-count (pb-seen-headers pb))) + ((>= index line-count) (values response-code protocol-version headers)) + (multiple-value-bind (header value) + (parse-header-line (svref left index) + (svref right index)) + (setf headers (add-header headers header value))))))))) + +(defun substring (string start &optional end downcasep) + (declare (type string string) (type fixnum start) (optimize (speed 3) (safety 0))) + (let* ((end (or end (length string))) + (rv (make-string (- end start)))) + (declare (type fixnum end)) + (do ((r-index start (1+ r-index)) + (w-index 0 (1+ w-index))) + ((>= r-index end) rv) + (declare (type fixnum r-index w-index)) + (setf (char rv w-index) + (let ((c (char string r-index))) + (if downcasep + (char-downcase c) + c)))))) + +(defun (setf substring) (new-value string &optional (start 0) end downcasep) + (declare (type string string new-value)) + (let* ((end (or end (length string))) + (end (min (+ start (length new-value)) end))) + (declare (type fixnum end)) + (do ((w-index start (1+ w-index)) + (r-index 0 (1+ r-index))) + ((>= w-index end) new-value) + (declare (type fixnum r-index w-index)) + (setf (char string w-index) + (let ((c (char new-value r-index))) + (if downcasep + (char-downcase c) + c)))))) + +(defun collect-to-char (char string &key (start 0) end downcasep) + (declare (type string string) + (type fixnum start) + (optimize (speed 3) (safety 0))) + (let ((end-index (position char string :start start :end end :test #'char=))) + (when end-index + (values (substring string start end-index downcasep) end-index)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HTTP DATE PARSING +;;; +;;; RFC 2616 says the following: +;;; +;;; HTTP-date = rfc1123-date | rfc850-date | asctime-date +;;; rfc1123-date = wkday "," SP date1 SP time SP "GMT" +;;; rfc850-date = weekday "," SP date2 SP time SP "GMT" +;;; asctime-date = wkday SP date3 SP time SP 4DIGIT +;;; date1 = 2DIGIT SP month SP 4DIGIT +;;; ; day month year (e.g., 02 Jun 1982) +;;; date2 = 2DIGIT "-" month "-" 2DIGIT +;;; ; day-month-year (e.g., 02-Jun-82) +;;; date3 = month SP ( 2DIGIT | ( SP 1DIGIT )) +;;; ; month day (e.g., Jun 2) +;;; time = 2DIGIT ":" 2DIGIT ":" 2DIGIT +;;; ; 00:00:00 - 23:59:59 +;;; wkday = "Mon" | "Tue" | "Wed" +;;; | "Thu" | "Fri" | "Sat" | "Sun" +;;; weekday = "Monday" | "Tuesday" | "Wednesday" +;;; | "Thursday" | "Friday" | "Saturday" | "Sunday" +;;; month = "Jan" | "Feb" | "Mar" | "Apr" +;;; | "May" | "Jun" | "Jul" | "Aug" +;;; | "Sep" | "Oct" | "Nov" | "Dec +;;; + +(defun parse-http-date (string) + (labels ((parse-month (s i) + (do ((j 1 (1+ j)) + (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + (rest m))) + ((or (> j 12) (string= (first m) s :start2 i :end2 (+ i 3))) + (and (< j 13) j)))) + (parse-int (s start end) + (parse-integer s :start start :end end :junk-allowed t)) + (encode-date (year month date hour minute second) + (when (and year month date hour minute second) + (encode-universal-time second minute hour date month year 0))) + (parse-time (s i) + (values (parse-int s i (+ i 2)) + (parse-int s (+ i 3) (+ i 5)) + (parse-int s (+ i 6) (+ i 8))))) + (cond + ;; -- RFC 1123 + ((char= (char string 3) #\,) + (let ((date (parse-int string 5 7)) + (month (parse-month string 8)) + (year (parse-int string 12 16))) + (multiple-value-bind (hour minute second) + (parse-time string 17) + (encode-date year month date hour minute second)))) + ;; -- ASCTIME + ((char= (char string 3) #\Space) + (let ((month (parse-month string 4)) + (date (parse-int string 8 10))) + (multiple-value-bind (hour minute second) + (parse-time string 11) + (multiple-value-bind (a b c d e year) + (decode-universal-time (get-universal-time)) + (declare (ignore a b c d e)) + (encode-date year month date hour minute second))))) + ;; -- RFC 850, with the assumption of 21st century + (t + (let ((p (position #\, string :test #'char=))) + (when p + (let ((date (parse-int string (+ p 2) (+ p 4))) + (month (parse-month string (+ p 5))) + (year (parse-int string (+ p 9) (+ p 11)))) + (multiple-value-bind (hour minute second) + (parse-time string (+ p 12)) + (encode-date (and year (+ year 2000)) + month date hour minute second))))))))) + +(defun parse-iso8601-date (string) + (labels ((fail-char-p (s c p) + (not (and (> (length s) p) + (char= (char s p) c)))) + (time-zone (s p) + (ecase (char s p) + (#\Z 0) + (#\- (parse-integer string :start (1+ p) :end (+ p 3))) + (#\+ (- (parse-integer string :start (1+ p) :end (+ p 3))))))) + (let ((year (parse-integer string :start 0 :end 4))) + (if (fail-char-p string #\- 4) + (values (encode-universal-time 0 0 0 1 1 year) t) + (let ((month (parse-integer string :start 5 :end 7))) + (if (fail-char-p string #\- 7) + (values (encode-universal-time 0 0 0 1 month year) t) + (let ((day (parse-integer string :start 8 :end 10))) + (if (fail-char-p string #\T 10) + (values (encode-universal-time 0 0 0 day month year) t) + (let ((hour (parse-integer string :start 11 :end 13)) + (min (parse-integer string :start 14 :end 16))) + (if (fail-char-p string #\: 16) + (values (encode-universal-time 0 min hour day month year + (time-zone string 16)) + nil) + (let ((sec (parse-integer string :start 17 :end 19))) + (values (encode-universal-time sec min hour day month year + (time-zone string 19)) + nil)))))))))))) + +(defun parse-exif-date (string) + (when (and (>= (length string) 10) + (char= (char string 4) #\:) + (char= (char string 7) #\:)) + (ignore-errors + (let ((day (parse-integer string :start 8 :end 10)) + (month (parse-integer string :start 5 :end 7)) + (year (parse-integer string :start 0 :end 4)) + (omit-time-p t) + (hour 0) + (min 0) + (sec 0)) + (when (and (>= (length string) 16) + (char= (char string 13) #\:)) + (setf hour (parse-integer string :start 11 :end 13) + min (parse-integer string :start 14 :end 16) + omit-time-p nil) + (when (and (= (length string) 19) + (char= (char string 16) #\:)) + (setf sec (parse-integer string :start 17 :end 19)))) + (values (encode-universal-time sec min hour day month year) omit-time-p))))) + +(defun iso8601-date-string (universal-time &optional omit-time-p) + (multiple-value-bind (sec min hour day month year weekday dst-p time-zone) + (decode-universal-time universal-time) + (declare (ignore weekday)) + (when (and dst-p (not (zerop time-zone))) + (decf time-zone)) ; thanks to Richard Newman for thinking of this + (if omit-time-p + (format nil "~4,'0D-~2,'0D-~2,'0D" + year month day) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~A~@[~2,'0D:00~]" + year month day hour min sec + (cond ((zerop time-zone) "Z") + ((> time-zone 0) "-") + (t "+")) + (and (not (zerop time-zone)) (abs time-zone)))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; PROXIES +;;; + +;;#-(and :openmcl :darwin :uffi) +(defvar *http-proxy* nil) + +;;#-(and :openmcl :darwin :uffi) +(defun find-http-proxy () + (or (get-env "HTTP-PROXY") *http-proxy*)) + +;;#+(and :openmcl :darwin :uffi) +#+:junk +(eval-when (:compile-toplevel :load-toplevel :execute) + (uffi:load-foreign-library + (translate-logical-pathname "wilbur:libs;FindProxies;build;FindProxies.dylib"))) + +#+(and :openmcl :darwin :uffi) +(uffi:def-function ("FindHTTPProxy" %find-http-proxy) + ((host (* :char)) + (host-size :unsigned-int)) + :returning :unsigned-byte) + +;;#+(and :openmcl :darwin :uffi) +#+:junk +(defun find-http-proxy () + (let ((buffer (uffi:allocate-foreign-string 256))) + (unwind-protect (progn + (%find-http-proxy buffer 256) + (let ((proxy-string (unless (%null-ptr-p buffer) + ;; UFFI:CONVERT-FROM-FOREIGN-STRING broken + (%get-cstring buffer)))) + (unless (zerop (length proxy-string)) + proxy-string))) + (uffi:free-foreign-object buffer)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SIMPLE-UNTYI-MIXIN +;;; + +(defclass simple-untyi-mixin () + ((last-char + :initform nil + :accessor stream-last-char))) + +(defmethod stream-tyi :around ((stream simple-untyi-mixin)) + (or (shiftf (stream-last-char stream) nil) + (call-next-method))) + +(defmethod stream-untyi ((stream simple-untyi-mixin) char) + (if (stream-last-char stream) + (error "Two UNTYIs in a row on ~S" stream) + (setf (stream-last-char stream) char))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS HTTP-NETWORK-STREAM (FOR MCL) +;;; + +#+(and :realmcl (not :http-using-aserve)) +(defclass http-network-stream (ccl::opentransport-tcp-stream) + ((via-proxy-p + :initform nil + :initarg :via-proxy-p + :reader stream-via-proxy-p) + (url-path + :initarg :url-path + :initform nil + :accessor stream-url-path)) + (:default-initargs + :reuse-local-port-p t + :writebufsize ccl::*ot-conn-outbuf-size*)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS HTTP-BODY-STREAM (FOR MCL) +;;; + +#+(and :realmcl (not :http-using-aserve)) +(defclass http-body-stream (simple-untyi-mixin input-stream) + ((chunkedp + :initform nil + :initarg :chunkedp + :accessor http-stream-chunked-p) + (count + :initform 0 + :initarg :character-count + :accessor http-stream-character-count) + (eofp + :initform nil + :accessor stream-eofp) + (network + :initarg :network-stream + ;; XXX: Why did I change this? It's totally gratutious. + ;; Make a decision before the final release. + :reader http-stream-network-stream))) + +;;; Now we eagerly read the chunk length. Note that there is still a serious problem with +;;; this stream, in that it doesn't know if it's really eofp and our buffering seems to +;;; get in the way of the correct OT errors being raised. I thought that reimplementing +;;; would fix that problem, but further reflection showed it just catches one case. +;;; +;;; Ultimately, it looks like the only solution is to implement this directly over OT, +;;; which is what CL-HTTP does. Or just tell people that we don't support read-sequence. + +#+(and :realmcl (not :http-using-aserve)) +(defmethod stream-tyi ((stream http-body-stream)) + (with-slots (network count chunkedp eofp) stream + (cond (chunkedp + (flet ((read-chunk-length () + (let* ((line (loop for char = (stream-tyi network) + while (not (char= char #\Linefeed)) + collecting char)) + (new-count (parse-integer (concatenate 'string line) + :radix 16 :junk-allowed t))) + (setf count new-count) + (when (zerop new-count) (setf eofp t))))) + (declare (dynamic-extent read-chunk-length)) + (when (null count) (read-chunk-length)) + (prog1 (stream-tyi network) + (when (zerop (decf count)) + (stream-tyi network) + (stream-tyi network) + (read-chunk-length))))) + ((null count) + (stream-tyi network)) + (t + (prog1 (stream-tyi network) + (when (zerop (decf count)) + (setf eofp t))))))) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod stream-close :after ((stream http-body-stream)) + (stream-close (http-stream-network-stream stream))) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod stream-abort :after ((stream http-body-stream)) + (stream-abort (http-stream-network-stream stream))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HTTP STREAM METHODS (FOR MCL) +;;; + +#+(and :realmcl (not :http-using-aserve)) +(defmethod open-http-stream ((url http-url) (proxy http-url)) + (make-instance 'http-network-stream + :host (url-host proxy) :port (url-port proxy) :via-proxy-p t)) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod open-http-stream ((url http-url) (proxy null)) + (make-instance 'http-network-stream + :host (url-host url) :port (url-port url))) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod make-http-body-stream ((stream http-network-stream)) + (make-instance 'http-body-stream :network-stream stream)) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod http-stream-enable-input-chunking ((stream http-body-stream)) + (setf (http-stream-chunked-p stream) t) + (setf (http-stream-character-count stream) nil)) + +#+(and :realmcl (not :http-using-aserve)) +(defmethod http-stream-disable-input-chunking ((stream http-body-stream)) + (setf (http-stream-chunked-p stream) nil)) diff --git a/src/core/literal.lisp b/src/core/literal.lisp new file mode 100644 index 0000000..4f7b8b7 --- /dev/null +++ b/src/core/literal.lisp @@ -0,0 +1,423 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; literal.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Definition of the class LITERAL and associated functionality +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LITERAL PROTOCOL +;;; + +(defgeneric literal-string (literal)) +(defgeneric literal-language (literal)) +(defgeneric literal-datatype (literal)) +(defgeneric literal-value (literal)) +(defgeneric (setf literal-value) (value literal)) +(defgeneric compute-literal-value (literal datatype string)) +(defgeneric literal= (literal other-literal)) +(defgeneric compute-literal-value-error (literal datatype string &rest options)) +(defgeneric literal-value->string (datatype value)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS LITERAL +;;; + +(defclass literal () + ((string + :initarg :string + :initform nil + :reader literal-string) + (language + :initarg :language + :initform nil + :reader literal-language) + (datatype + :initarg :datatype + :initform nil + :reader literal-datatype) + (value + :accessor literal-value))) + +(defmethod literal-string ((literal string)) + literal) + +(defmethod literal-language ((literal string)) + nil) + +(defmethod literal-datatype ((literal string)) + nil) + +(defmethod literal-value ((literal string)) + literal) + +(defmethod literal-value :around ((literal literal)) + (if (slot-boundp literal 'value) + (call-next-method) + (setf (literal-value literal) + (compute-literal-value literal + (literal-datatype literal) (literal-string literal))))) + +(defmethod print-object ((self literal) stream) + (princ #\# stream) + (print-literal-for-ntriples self stream)) + +(defmethod compute-literal-value ((literal literal) + (datatype null) + string) + string) + +(defun %literal= (string datatype language other-literal) + (and (string= string (literal-string other-literal)) + (if datatype + (eql datatype (literal-datatype other-literal)) + (let ((other-language (literal-language other-literal))) + (or (and (null language) (null other-language)) + (string-equal language other-language)))))) + +(defmethod literal= ((literal string) (other-literal string)) + (string= literal other-literal)) + +(defmethod literal= ((literal literal) (other-literal literal)) + (%literal= (literal-string literal) + (literal-datatype literal) (literal-language literal) + other-literal)) + +(defmethod literal= ((literal literal) (other-literal string)) + (%literal= other-literal nil nil literal)) + +(defmethod literal= ((literal string) (other-literal literal)) + (%literal= literal nil nil other-literal)) + +(defmethod literal= (literal other-literal) + (declare (ignore literal other-literal)) + nil) + +(defmethod literal-language-match-p ((literal literal) language) + (string-equal (literal-language literal) language :end1 (length language))) + +(defmethod literal-language-match-p (thing language) + (declare (ignore thing language)) + nil) + +(defmethod compute-literal-value-error ((literal literal) + (datatype node) + string + &key (value string) + (warn-only-p nil)) + (unless warn-only-p + (cerror (format nil "Use value ~S instead" value) + 'datatype-parse-error :thing string)) + (warn "Ignoring literal datatype ~S for literal ~S" datatype string) + value) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LITERAL PARSING +;;; +;;; This is the template for COMPUTE-LITERAL-VALUE methods: +;;; +;;; (defmethod compute-literal-value ((literal literal) +;;; (datatype (eql !xsd:...)) +;;; string) +;;; ...) +;;; + +(defmethod compute-literal-value ((literal literal) + (datatype node) + string) + (compute-literal-value-error literal datatype string :warn-only-p t)) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:string)) + string) + string) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:boolean)) + string) + (cond ((or (string= string "1") (string= string "true")) t) + ((or (string= string "0") (string= string "false")) nil) + (t (compute-literal-value-error literal datatype string :value nil)))) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:float)) + string) + (compute-literal-value-float literal datatype string)) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:double)) + string) + (compute-literal-value-float literal datatype string)) + +(defun compute-literal-value-float (literal datatype string) + (multiple-value-bind (value n) + (read-from-string string :eof-error-p nil) + (if (and value (numberp value) (= n (length string))) + (float value) + (compute-literal-value-error literal datatype string :value 1.0)))) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:dateTime)) + string) + (or (ignore-errors (parse-iso8601-date string)) + (compute-literal-value-error literal datatype string :value 0))) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:date)) + string) + (or (and (= (length string) 10) + (ignore-errors (parse-iso8601-date string))) + (compute-literal-value-error literal datatype string :value 0))) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:normalizedString)) + string) + (flet ((illegalp (c) + (or (char= c #\Return) + (char= c #\Linefeed) + (char= c #\Tab)))) + (declare (dynamic-extent #'illegalp)) + (if (find-if #'illegalp string) + (compute-literal-value-error literal datatype string + :value (substitute-if #\Space #'illegalp string)) + string))) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:integer)) + string) + (compute-literal-value-integer literal datatype string)) + +(defmethod compute-literal-value ((literal literal) + (datatype (eql !xsd:int)) + string) + (compute-literal-value-integer literal datatype string)) + +(defun compute-literal-value-integer (literal datatype string) + (or (parse-integer string :junk-allowed t) + (compute-literal-value-error literal datatype string :value 0))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; OUTPUT FUNCTIONS +;;; + +(defmethod print-literal-for-ntriples ((literal literal) stream) + (let ((datatype (literal-datatype literal))) + (format stream "~S~@[@~A~]~@[^^<~A>~]" + (literal-string literal) + (literal-language literal) + (and datatype (find-short-name *nodes* (node-uri datatype)))))) + +(defmethod literal-value->string ((datatype (eql !xsd:string)) + (value string)) + value) + +(defmethod literal-value->string ((datatype (eql !xsd:boolean)) + value) + (if value "true" "false")) + +(defmethod literal-value->string ((datatype (eql !xsd:float)) + (value float)) + (prin1-to-string value)) + +(defmethod literal-value->string ((datatype (eql !xsd:double)) + (value float)) + (prin1-to-string value)) + +(defmethod literal-value->string ((datatype (eql !xsd:dateTime)) + (value integer)) + (iso8601-date-string value)) + +(defmethod literal-value->string ((datatype (eql !xsd:date)) + (value integer)) + (iso8601-date-string value t)) + +(defmethod literal-value->string ((datatype (eql !xsd:normalizedString)) + (value string)) + (flet ((illegalp (c) + (or (char= c #\Return) + (char= c #\Linefeed) + (char= c #\Tab)))) + (declare (dynamic-extent #'illegalp)) + (assert (not (find-if #'illegalp value))) + value)) + +(defmethod literal-value->string ((datatype (eql !xsd:integer)) + (value integer)) + (prin1-to-string value)) + +(defmethod literal-value->string ((datatype (eql !xsd:int)) + (value integer)) + (prin1-to-string value)) + +(defmethod literal-value->string ((datatype null) + (value string)) + value) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LITERAL SHORTHAND SYNTAX +;;; + +(defun literal (string &rest options) + (declare (dynamic-extent options)) + (apply #'db-make-literal *db* string options)) + +(defmethod make-load-form ((literal literal) &optional env) + (declare (ignore env)) + (let ((datatype (literal-datatype literal)) + (language (literal-language literal))) + `(literal ,(literal-string literal) + ,@(and datatype `(:datatype ,datatype)) + ,@(and language `(:language ,language))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defun inline-literal-reader (stream char arg) + (declare (ignore arg)) + (unread-char char stream) + (let ((string (read stream t nil t))) + ;; later, when I get around to it, we will also read datatype and language + (literal string))) + + (defun enable-literal-shorthand () + (set-dispatch-macro-character #\# #\" #'inline-literal-reader)) + + (enable-literal-shorthand)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS INTERNED-LITERAL +;;; MIXIN CLASS INTERNED-LITERAL-DB-MIXIN +;;; CLASS INTERNED-LITERAL-INDEXED-DB +;;; + +(defclass interned-literal (literal node) + ()) + +(defmethod literal= ((literal interned-literal) (other-literal interned-literal)) + (eq literal other-literal)) + +(defclass interned-literal-db-mixin () ; mix with class db + ((literal-index + :initform (make-hash-table :test #'equal) + :reader db-literal-index)) + (:default-initargs + :literal-class 'interned-literal)) + +(defmethod db-literal-index-get ((db interned-literal-db-mixin) string + &key datatype language + &allow-other-keys) + (find-if #'(lambda (literal) + (%literal= string datatype language literal)) + (gethash string (db-literal-index db)))) + +(defmethod (setf db-literal-index-get) ((literal interned-literal) + (db interned-literal-db-mixin) string) + ;; "It is an error" to call this without first checking for the prior existence + ;; of the literal in the index + (push literal (gethash string (db-literal-index db))) + literal) + +(defmethod db-make-literal ((db interned-literal-db-mixin) string &rest options) + (declare (dynamic-extent options)) + (or (apply #'db-literal-index-get db string options) + (setf (db-literal-index-get db string) (call-next-method)))) + +(defclass interned-literal-indexed-db (interned-literal-db-mixin indexed-db) + ()) + +(defmethod db-literal-index-find ((db interned-literal-db-mixin) string) + (let ((literals nil)) + (maphash #'(lambda (key value) + (when (name-contains-pattern-p key string) + (setf literals (append value literals)))) + (db-literal-index db)) + (copy-list literals))) diff --git a/src/core/rdf-parser.lisp b/src/core/rdf-parser.lisp new file mode 100644 index 0000000..646e279 --- /dev/null +++ b/src/core/rdf-parser.lisp @@ -0,0 +1,674 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; rdf-parser.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains an implementation of an RDF parser, using a +;;; "near streaming" algorithm based on a simple state machine. The parser +;;; implements all of RDF M+S excluding "aboutEachPrefix" (what, are you +;;; surprised?) as well as RDFCore. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS RDF-SYNTAX-NORMALIZER +;;; + +(defclass rdf-syntax-normalizer (sax-filter) + ()) + +(defmethod sax-consumer-mode ((self rdf-syntax-normalizer)) + (sax-consumer-mode (sax-producer-consumer self))) + +(defmethod start-element ((self rdf-syntax-normalizer) + (tag open-tag) + mode) + (let ((attributes (tag-attributes tag)) + (properties nil) + (consumer (sax-producer-consumer self)) + (namespaces (tag-namespaces tag))) + (do-string-dict (key value attributes) + (cond ((null (find key -rdf-attrs- :test #'string=)) + (setf properties (string-dict-add properties key value) + attributes (string-dict-del attributes key))) + ((string= key -rdf-abouteachprefix-uri-) + (cerror "Ignore" 'feature-not-supported :thing "aboutEachPrefix") + (setf attributes (string-dict-del attributes key))))) + (setf (tag-attributes tag) attributes) + (start-element consumer tag mode) + (do-string-dict (key value properties) + (unless (or (string= key -xml-lang-attr-) + (string= key "xml:space") + (string= key "xml:base")) + (let ((new-tag (make-instance 'open-tag + :string key + :base (tag-base tag) + :namespaces namespaces))) + (start-element consumer new-tag (sax-consumer-mode self)) + (char-content consumer value (sax-consumer-mode self)) + (end-element consumer new-tag (sax-consumer-mode self))))))) + +(defmethod maybe-use-namespace ((self rdf-syntax-normalizer) prefix uri) + (maybe-use-namespace (sax-producer-consumer self) prefix uri)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS RDF-PARSER +;;; + +(defclass temporary-parser-db (interned-literal-db-mixin fast-temporary-db) + ()) + +(defclass rdf-parser (sax-consumer) + ((base + :initform nil + :accessor parser-base) + (locator + :initform nil + :accessor parser-locator) + (db + :initarg :db + :initform nil + :accessor parser-db) + (states + :initform nil + :accessor parser-states) + (literal + :accessor parser-literal) + (rdfcorep + :initarg rdfcorep + :initform t + :accessor parser-rdfcore-p) + (harvest-namespaces-p + :initarg :harvest-namespaces-p + :initform t + :reader parser-harvest-namespaces-p) + (db-class + :initarg :db-class + :initform 'temporary-parser-db + :reader parser-db-class) + (initial-state + :initarg :initial-state + :initform :scan + :reader parser-initial-state) + (nodeids + :initform nil + :accessor parser-nodeids) + (load-queue + :initform nil + :accessor parser-load-queue)) + (:default-initargs + :producer (make-instance 'xml-parser + :consumer (make-instance 'rdf-syntax-normalizer)))) + +(define-condition close-rdf-element (condition) + ()) + +(defstruct (state (:constructor make-state (mode + &optional node + property + statement-id + language + datatype))) + mode + node + triple + property + (statement-id nil) + (language nil) + (datatype nil) + (index 0) + task-queue) + +(defun add-state (parser mode &rest args) + (declare (dynamic-extent args)) + (push (apply #'make-state mode args) (parser-states parser))) + +(defun parser-task-state (parser) + (find :description (parser-states parser) :key #'state-mode)) + +(defmethod sax-consumer-mode ((parser rdf-parser)) + (state-mode (first (parser-states parser)))) + +(defstruct (task (:constructor make-task (type node &rest parameters))) + type + node + parameters) + +(defmacro task-parameter (task parameter) + `(getf (task-parameters ,task) ,parameter)) + +(defmethod defer-task ((parser rdf-parser) type node &rest args) + (declare (dynamic-extent args)) + (pushnew (apply #'make-task type node args) + (state-task-queue (parser-task-state parser)) + :test #'(lambda (p q) + (and (eq (task-type p) (task-type q)) + (eq (task-node p) (task-node q)))))) + +(defmethod make-container ((parser rdf-parser) + elements + &optional container-uri + (container-type-uri -rdf-bag-uri-)) + (let ((node (ensure-node parser container-uri nil)) + (i 0)) + (add-as-triple parser node + (ensure-node parser -rdf-type-uri- t) + (ensure-node parser container-type-uri t)) + (dolist (element elements) + (add-as-triple parser node (index-uri (incf i) (parser-db parser)) element)) + node)) + +(defmethod initialize-instance :after ((parser rdf-parser) &key &allow-other-keys) + (let ((normalizer (sax-producer-consumer (sax-consumer-producer parser)))) + (setf (sax-producer-consumer normalizer) parser) + (unless (parser-db parser) + (setf (parser-db parser) (make-instance (parser-db-class parser) :emptyp t))))) + +(defun uri (parser uri should-exist-p) + (let* ((base (first (parser-base parser))) + (base-end-char (char base (1- (length base)))) + (ends-in-hash-p (char= base-end-char #\#))) + (cond ((or (null uri) (find #\: uri :test #'char=) (char= (char uri 0) #\/)) + ;; FULL URI W/ SCHEME + uri) + ((char= (char uri 0) #\#) + ;; FRAGMENT IDENTIFIER + (concatenate 'string base (if ends-in-hash-p (subseq uri 1) uri))) + ((not should-exist-p) + ;; ESTABLISHES A FRAGMENT (NO HASH IN FRONT) + (concatenate 'string base (if ends-in-hash-p nil "#") uri)) + ((char= base-end-char #\/) + ;; RELATIVE URI, BASE ENDS IN SLASH + (concatenate 'string base uri)) + (t + ;; RELATIVE URI, BASE DOES NOT END IN SLASH + (let ((i (position #\/ base :from-end t :test #'char=))) + (concatenate 'string (subseq base 0 (and i (1+ i))) uri)))))) + +(defun ensure-node (parser uri should-exist-p) + (cond ((and (stringp uri) (zerop (length uri))) + (node (first (parser-base parser)))) + ((typep uri 'node) + uri) + (t + (node (uri parser uri should-exist-p))))) + +(defun ensure-named-bnode (parser nodeid) + (or (cdr (assoc nodeid (parser-nodeids parser) :test #'string=)) + (let ((node (ensure-node parser nil nil))) + (push (cons nodeid node) (parser-nodeids parser)) + node))) + +(defmethod parse ((parser rdf-parser) stream locator) + (setf (parser-load-queue parser) nil) + (catch :terminate-rdf-parser + (parse (find-first-producer parser) stream locator)) + (dolist (url (parser-load-queue parser)) + (ensure-ontology-loaded parser url)) + (parser-locator parser)) + +(defmethod ensure-ontology-loaded ((parser rdf-parser) url) + ;; simplistic ontology loader, can be overridden + (cond ((or (db-source-loaded-p *db* (db-find-source-desc *db* url nil)) + (db-query *db* (node url) !rdf:type !owl:Ontology)) + (format t "owl:imports ~a already done~%" url) + nil) + (t + (format t "~&Import of ~S~%" url) + (db-load *db* url :merge-results-p t :verbosep nil) + t))) + +(defmethod add-as-triple ((parser rdf-parser) + (subject node) + (predicate string) + object + &optional statement-id) + (add-as-triple parser subject (ensure-node parser predicate t) object statement-id)) + +(defmethod add-as-triple ((parser rdf-parser) + (subject node) + (predicate node) + object + &optional statement-id) + (let* ((db (parser-db parser)) + (source (parser-locator parser)) + (triple (db-make-triple db subject predicate object source))) + (db-add-triple db triple) + (dolist (state (parser-states parser)) + ;; for higher order statements + (dolist (task (state-task-queue state)) + (when (and (eq (task-type task) :bagid) + (eq subject (task-node task))) + (push (cons triple statement-id) (task-parameter task :statements)) + (return-from add-as-triple triple)))) + (when statement-id + ;; no bagid but statement-id exists + (db-reify triple db (uri parser statement-id nil) source)) + triple)) + +(defun new-index-uri (parser db) + (index-uri (incf (state-index (first (parser-states parser)))) db)) + +(defun parse-db-from-stream (stream locator + &rest options + &key (parser-class 'rdf-parser) + &allow-other-keys) + (declare (dynamic-extent options)) + (remf options :parser-class) + (multiple-value-bind (source-node parser) + (apply #'parse-from-stream + stream locator parser-class options) + (values (parser-db parser) source-node))) + +(defmethod maybe-use-namespace ((self rdf-parser) prefix uri) + (when (and (parser-harvest-namespaces-p self) + (not (string-dict-get (dictionary-namespaces *nodes*) prefix))) + (add-namespace prefix uri))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF PARSER STATE MACHINE TRANSITIONS +;;; + +(defmethod start-document ((parser rdf-parser) + locator) + (setf (parser-locator parser) (node locator) + (parser-base parser) (list locator) + (parser-nodeids parser) nil) + (add-state parser (parser-initial-state parser))) + +(defmethod end-document ((parser rdf-parser) + mode) + (declare (ignore mode)) + nil) + +(defmethod start-element :before ((parser rdf-parser) + (tag open-tag) + mode) + (declare (ignore mode)) + (push (tag-base tag) (parser-base parser))) + +(defmethod end-element :after ((parser rdf-parser) + (tag open-tag) + mode) + (declare (ignore mode)) + (pop (parser-base parser))) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :scan))) + (cond ((string= (token-string tag) -rdf-rdf-uri-) + (add-state parser :description)) + ((string= (token-string tag) -rdf-description-uri-) + (start-element parser tag :description)))) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :description))) + (let ((each (tag-attribute tag -rdf-abouteach-uri-)) + (about (tag-attribute tag -rdf-about-uri-)) + (id (tag-attribute tag -rdf-id-uri-)) + (nodeid (tag-attribute tag -rdf-nodeid-uri-))) + (when (and about id) + (cerror "Use \"about\"" 'about-and-id-both-present)) + (when (and (or about id) nodeid) + (cerror "Ignore \"nodeID\"" 'about-and-nodeid-both-present) + (setf nodeid nil)) + (let ((type (token-string tag)) + (node (if nodeid + (ensure-named-bnode parser nodeid) + (ensure-node parser + (and (null each) (or about id)) + (and (null each) (null id)))))) + (if each + (if (parser-rdfcore-p parser) + (cerror "Ignore \"aboutEach\"" 'feature-disabled :feature "aboutEach") + (defer-task parser :abouteach node :target (ensure-node parser each t))) + (let* ((bagid (tag-attribute tag -rdf-bagid-uri-)) + (state (first (parser-states parser))) + (parent (state-node state))) + (when bagid + (defer-task parser :bagid node :bagid bagid :statements nil)) + (when parent + (attach-to-parent parser parent node (state-statement-id state))))) + (unless (string= type -rdf-description-uri-) + (add-as-triple parser node -rdf-type-uri- (ensure-node parser type t))) + (add-state parser :property node)))) + +(defmethod attach-to-parent ((parser rdf-parser) + (parent node) + (child node) + &optional statement-id) + (let ((state (first (parser-states parser)))) + (cond ((eq (state-mode state) :collection) + (setf parent (state-node state)) + (add-as-triple parser parent -rdf-first-uri- child) + (setf (state-triple state) + (add-as-triple parser parent -rdf-rest-uri- + (setf (state-node state) (ensure-node parser nil t))))) + ((eq (state-mode state) :daml-collection) + (let ((parent (state-node state)) + (node (ensure-node parser nil t))) + (add-as-triple parser parent -rdf-type-uri- + (ensure-node parser -daml-list-uri- t)) + (add-as-triple parser parent -daml-first-uri- child) + (add-as-triple parser parent -daml-rest-uri- node) + (setf (state-node state) node))) + (t + (add-as-triple parser parent + (state-property (first (parser-states parser))) + child statement-id))))) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :property))) + (when (string= (token-string tag) -owl-imports-uri-) + (pushnew (tag-attribute tag -rdf-resource-uri-) (parser-load-queue parser))) + (let* ((state (first (parser-states parser))) + (node (state-node state)) + (property-uri (token-string tag)) + (property (ensure-node parser + (cond ((string= property-uri -rdf-li-uri-) + ;; (defer-task parser :container node) + (new-index-uri parser (parser-db parser))) + (t + property-uri)) + t)) + (resource-uri (tag-attribute tag -rdf-resource-uri-)) + (nodeid (tag-attribute tag -rdf-nodeid-uri-)) + (statement-id (tag-attribute tag -rdf-id-uri-))) + (cond (resource-uri + (let ((value (ensure-node parser resource-uri t))) + (setf (state-property state) property) + (attach-to-parent parser node value statement-id) + (add-state parser :property value))) + (nodeid + (let ((value (ensure-named-bnode parser nodeid))) + (setf (state-property state) property) + (attach-to-parent parser node value statement-id) + (add-state parser :property value))) + (t + (parse-using-parsetype parser node property + (tag-attribute tag -rdf-parsetype-uri-) + statement-id + (tag-attribute tag -xml-lang-attr-) + (tag-attribute tag -rdf-datatype-uri-)))))) + +(defmethod parse-using-parsetype ((parser rdf-parser) node property parsetype + &optional statement-id language datatype) + (cond ((null parsetype) + (add-state parser :description node property statement-id language datatype)) + ((string-equal parsetype "Literal") + (setf (parser-literal parser) nil) + (add-state parser :literal node property)) + ((string-equal parsetype "Resource") + (add-as-triple parser node property (setf node (ensure-node parser nil t)) + statement-id) + (add-state parser :property node)) + ((string-equal parsetype "Collection") ; adapted from daml-parser + (let ((list-node (ensure-node parser nil t))) + (add-as-triple parser node property list-node) + (add-state parser :collection list-node))) + ((string= parsetype "daml:collection") + (let ((list-node (ensure-node parser nil t))) + (add-as-triple parser node property list-node) + (add-state parser :daml-collection list-node))) + (t + (cerror "Ignore parseType" 'unknown-parsetype :thing parsetype)))) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :literal))) + (add-state parser :literal) + (push tag (parser-literal parser))) + +(declaim (special *db*)) + +(defmethod end-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :literal))) + (let ((state (first (parser-states parser)))) + (call-next-method) + (cond ((not (null (state-node state))) + (let ((string (with-output-to-string (s) + (replay (make-instance 'xml-formatter :stream s) + (nreverse (parser-literal parser)))))) + (add-as-triple parser + (state-node state) + (state-property state) + (db-make-literal (or *db* (parser-db parser)) string)))) + ((not (tag-empty-p tag)) + (push (tag-counterpart tag) (parser-literal parser)))))) + +(defmethod end-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :scan))) + nil) + +(defmethod end-element :after ((parser rdf-parser) + (tag open-tag) + (mode (eql :property))) + (let ((state (parser-task-state parser))) + (when state + (dolist (task (shiftf (state-task-queue state) nil)) + (execute-deferred-task parser task (task-type task)))))) + +(defmethod execute-deferred-task ((parser rdf-parser) task type) + (let ((db (parser-db parser)) + (source (node (first (parser-base parser))))) + (ecase type + ;; (:container + ;; (is-container-p db (task-node task) t) + ;; t) + (:abouteach + (let ((target (task-parameter task :target)) + (index-predicates nil)) + (is-container-p db target t) + (dolist (triple (db-query db target nil nil)) + (let ((uri (node-uri (triple-predicate triple)))) + (when (find uri *index-uris* :test #'string=) + (push (ensure-node parser uri t) index-predicates)))) + (dolist (triple (db-query db (task-node task) nil nil)) + (db-del-triple db triple) + (dolist (p index-predicates) + (add-as-triple parser + (triple-object (first (db-query db target p nil))) + (triple-predicate triple) + (triple-object triple) + source))))) + (:bagid + (let ((statements (task-parameter task :statements))) + (when statements + (make-container parser + (mapcar #'(lambda (s) + (destructuring-bind (triple . id) s + (db-reify triple db + (and id (uri parser id nil)) + source))) + statements) + (uri parser (task-parameter task :bagid) nil)))))))) + +(defmethod end-element :after ((parser rdf-parser) + (tag open-tag) + (mode (eql :description))) + (when (string= (token-string tag) -rdf-rdf-uri-) + (signal 'close-rdf-element))) + +(defmethod end-element ((parser rdf-parser) + (tag open-tag) + mode) + (declare (ignore mode)) + (pop (parser-states parser))) + +(defmethod char-content ((parser rdf-parser) + (content string) + (mode (eql :description))) + (let* ((state (first (parser-states parser))) + (datatype (state-datatype state)) + (property (state-property state))) + (add-as-triple parser (state-node state) property + (db-make-literal (or *db* (parser-db parser)) content + :language (state-language state) + :datatype (and datatype (node datatype)) + :property property) + (state-statement-id state)))) + +(defmethod char-content ((parser rdf-parser) + (content string) + (mode (eql :literal))) + (push content (parser-literal parser))) + +(defmethod char-content ((parser rdf-parser) + (content string) + (mode (eql :scan))) + ;; ignore character content in :scan mode + nil) + +(defmethod char-content ((parser rdf-parser) + (content string) + mode) + (declare (ignore mode)) + (cerror "Ignore" 'illegal-character-content :thing content)) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :collection))) + (start-element parser tag :description)) + +(defmethod start-element ((parser rdf-parser) + (tag open-tag) + (mode (eql :daml-collection))) + (start-element parser tag :description)) + +(defmethod end-element :before ((parser rdf-parser) + (tag open-tag) + (mode (eql :collection))) + (let* ((db (parser-db parser)) + (triple (db-del-triple db (state-triple (first (parser-states parser)))))) + (add-as-triple parser + (triple-subject triple) + (triple-predicate triple) + (ensure-node parser -rdf-nil-uri- t)))) + +(defmethod end-element :before ((parser rdf-parser) + (tag nox:open-tag) + (mode (eql :daml-collection))) + (let* ((node (state-node (first (parser-states parser)))) + (db (parser-db parser)) + (triple (db-del-triple db (first (db-query db nil nil node))))) + (add-as-triple parser + (triple-subject triple) + (triple-predicate triple) + (ensure-node parser -daml-nil-uri- t)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CONSTRUCTORS FOR COLLECTIONS +;;; + +(defun rdf-list (&rest items) + (declare (dynamic-extent items)) + (if items + (rdf-cons (first items) (apply #'rdf-list (rest items))) + !rdf:nil)) + +(defun rdf-cons (first rest &optional uri) + (let ((pair (node uri))) + (add-triple (triple pair !rdf:type (node -rdf-list-uri-))) + (add-triple (triple pair (node -rdf-first-uri-) first)) + (add-triple (triple pair (node -rdf-rest-uri-) rest)) + pair)) + +(defun daml-list (&rest items) + (if items + (daml-cons (first items) (apply #'daml-list (rest items))) + !daml:nil)) + +(defun daml-cons (first rest &optional uri) + (let ((pair (node uri))) + (add-triple (triple pair !rdf:type (node -daml-list-uri-))) + (add-triple (triple pair (node -daml-first-uri-) first)) + (add-triple (triple pair (node -daml-rest-uri-) rest)) + pair)) diff --git a/src/core/reasoner.lisp b/src/core/reasoner.lisp new file mode 100644 index 0000000..1d0e7cd --- /dev/null +++ b/src/core/reasoner.lisp @@ -0,0 +1,542 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; reasoner.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file implements an RDFS reasoner, originally based on (but extending) +;;; this paper: +;;; +;;; Ora Lassila: "Taking the RDF Model Theory Out for a Spin", in: Ian Horrocks & +;;; James Hendler (eds.): "The Semantic Web - ISWC 2002", Lecture Notes in Computer +;;; Science 2342, pp.307-317, Springer Verlag, 2002 +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; MIXIN CLASS DEDUCTIVE-CLOSURE-DB-MIXIN +;;; + +(defclass deductive-closure-db-mixin () + ((closurep + :initarg :closurep + :initform t + :accessor db-closure-p) + (use-rule-engine-p + :initarg :use-rule-engine-p + :initform t + :reader db-use-rule-engine-p) + (sameas-clusters + :initform (make-hash-table :test #'eq) + :reader db-sameas-clusters) + (ifp-additions + :initform (make-triple-collection) + :reader db-ifp-additions)) + (:default-initargs + :rdf-schema-pathname "wilbur:schemata;true-rdf-schema.rdf")) + +(defmacro without-closure ((db) &body body) + (let ((d (gentemp)) + (closurep (gentemp))) + `(let* ((,d ,db) + (,closurep nil)) + (unwind-protect (progn + (shiftf ,closurep (db-closure-p ,d) nil) + ,@body) + (setf (db-closure-p ,d) ,closurep))))) + +(defvar *subprop-query* nil) +(defvar *subprops-of-subprop* (list !rdfs:subPropertyOf)) + +(declaim (special *rewritten-paths*)) ; forward ref. + +(defmethod db-add-triple ((db deductive-closure-db-mixin) (triple triple) + &optional source) + (declare (ignore source)) + (multiple-value-bind (triple addedp new-sources) + (call-next-method) + (when addedp + (db-add-triple-post-process db triple)) + (values triple addedp new-sources))) + +(defmethod db-add-triple-post-process ((db deductive-closure-db-mixin) (triple triple)) + (let ((p (triple-predicate triple)) + (o (triple-object triple))) + (db-add-triple db (db-make-triple db p !rdf:type !rdf:Property) :closure) + (cond ((eq p !rdf:type) + (db-add-triple db (db-make-triple db o !rdf:type !rdfs:Class) :closure)) + ((eq p !owl:sameAs) + (db-update-sameas-clusters db (triple-subject triple))) + ((member p *subprops-of-subprop*) + (db-clear-reasoner-cache db) + (when (member o *subprops-of-subprop*) + (setf *subprops-of-subprop* + (db-get-values db !rdfs:subPropertyOf (subprop-query db)) + *subprop-query* nil))) + ((and (typep o 'literal) + (literal-datatype o)) + (db-add-triple db (db-make-triple db o !rdf:type !rdf:XMLLiteral) + :closure))))) + +(defmethod db-del-triple ((db deductive-closure-db-mixin) (triple triple) + &optional source) + (declare (ignore source)) + (multiple-value-bind (triple deletedp new-sources) + (call-next-method) + (when (and deletedp (eq (triple-predicate triple) !owl:sameAs)) + (db-update-sameas-clusters db (triple-subject triple)) + (db-update-sameas-clusters db (triple-object triple))) + (values triple deletedp new-sources))) + +(defmethod db-merge :after ((to deductive-closure-db-mixin) (from db) &optional source) + (declare (ignore source)) + (db-clear-reasoner-cache to)) + +(defmethod db-new-container-membership-property ((db deductive-closure-db-mixin) + (property node)) + (flet ((tr (s p o) + (db-add-triple db (db-make-triple db s p o)))) + (tr property !rdf:type !rdfs:ContainerMembershipProperty) + (tr property !rdfs:subPropertyOf !rdfs:member))) + +(defmethod db-get-values :around ((db deductive-closure-db-mixin) (frame node) path) + ;; We cannot check the status of reasoning, since WilburQL queries are executed without + ;; reasoning, yet owl:sameAs support has to work... this could be a problem, but for now + ;; we just ignore the whole matter. + (let* ((sameas-clusters (db-sameas-clusters db)) + (other-frames (gethash frame sameas-clusters))) + ;;(remove-duplicates + (cond ((eq path !owl:sameAs) + (if (db-closure-p *db*) ; why is this *db* ?? + other-frames + (call-next-method))) + ((rest other-frames) + (reduce #'union (mapcar #'(lambda (f) + (call-next-method db f path)) + other-frames))) + (t + (call-next-method))) + ;; :test #'(lambda (x y) + ;; (find x (gethash y sameas-clusters)))) + )) + +(defmethod db-get-values ((db deductive-closure-db-mixin) (frame node) path) + (let ((path (rewrite-path path db))) + (without-closure (db) + (call-next-method db frame path)))) + +(defmethod db-get-values ((db deductive-closure-db-mixin) + (frame (eql !rdfs:Resource)) + (path inverse-slot)) + (let ((link (inverse-slot-node path))) + (if (or (eq link !rdf:type) (eq link !rdfs:subClassOf)) + ;;(cons :all (call-next-method)) + (list :all) + (call-next-method)))) + +(defmethod frames-related-p ((source node) path (sink node) + (db deductive-closure-db-mixin) + action) + (let ((path (rewrite-path path db))) + (without-closure (db) + (call-next-method source path sink db action)))) + +(defmethod db-update-sameas-clusters ((db deductive-closure-db-mixin) + (node node)) + (let ((cluster (without-closure (db) + (db-get-values db node '(:rep* (:or !owl:sameAs (:inv !owl:sameAs)))))) + (clusters (db-sameas-clusters db))) + (if (rest cluster) + (dolist (i cluster) + (setf (gethash i clusters) cluster)) + (remhash node clusters)))) + +(defun show-sameas-clusters (db) + (maphash #'(lambda (key value) + (format t "~&~S: ~S" key value)) + (db-sameas-clusters db))) + +(defmethod db-node-duplicates ((db deductive-closure-db-mixin) (node node)) + (gethash node (db-sameas-clusters db))) + +(defmethod db-nodes-same-p ((db deductive-closure-db-mixin) (node1 node) (node2 node)) + (member node2 (db-node-duplicates db node1))) + +(defmethod db-remove-node-duplicates ((db deductive-closure-db-mixin) nodes) + ;; this needs to be optimized for long lists (how long? what's the threshold?) + (let ((to-be-removed nil)) + (delete-if #'(lambda (node) + (or (member node to-be-removed) + (dolist (dup (db-node-duplicates db node)) + (push dup to-be-removed)))) + (sort (copy-list nodes) + #'(lambda (node1 node2) + (declare (ignore node2)) + (node-uri node1)))))) + +(defmethod db-identified-node ((db deductive-closure-db-mixin) (node node) + &optional (error-if-unidentified-p nil)) + (let* ((nodes (db-node-duplicates db node)) + (candidate (if nodes + (or (find-if #'node-uri nodes) node) + node))) + (when (and error-if-unidentified-p (null (node-uri candidate))) + (cerror "Ignore" 'unidentifed-node :thing node)) + candidate)) + +(defmethod db-identified-node ((db deductive-closure-db-mixin) (literal literal) + &optional error-if-unidentified-p) + (declare (ignore error-if-unidentified-p)) + literal) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; PATH REWRITING +;;; + +(defvar *rewritten-paths* (make-hash-table :test #'equal)) +(defvar *known-rewrite-rules* (make-hash-table :test #'eq)) + +(defun rewrite-path (path db) + (if (or (typep path 'path) + (not (db-closure-p db))) + path + (or (gethash path *rewritten-paths*) + (let ((p (rewrite-path-for-subproperties + (rewrite-path-for-types (if (db-use-rule-engine-p db) + (rewrite-path-using-rule-engine path db) + path) + db) + db))) + (setf (gethash path *rewritten-paths*) + (make-instance 'path :db db :expression p)))))) + +(defmacro define-rewrite-function (name (expr db) &body body) + (let ((op (gentemp)) + (var (gentemp))) + `(defun ,name (,expr ,db) + (typecase ,expr + (node ,@body) + (cons (let ((,op (first ,expr))) + (case ,op + ((:value :norewrite) ,expr) + (t (cons ,op + (mapcar #'(lambda (,var) + (,name ,var ,db)) + (rest ,expr))))))) + (t ,expr))))) + +(define-rewrite-function rewrite-path-for-types (path db) + (case path + (!rdf:type + '(:or (:seq !rdf:type (:rep* !rdfs:subClassOf)) + (:seq :predicate-of-object !rdfs:range (:rep* !rdfs:subClassOf)) + (:seq :predicate-of-subject !rdfs:domain (:rep* !rdfs:subClassOf)) + (:value !rdfs:Resource))) + (!rdfs:subClassOf + ;; '(:or (:rep* !rdfs:subClassOf) (:value !rdfs:Resource)) + '(:or (:seq+ (:rep+ !rdfs:subClassOf) (:value !rdfs:Resource)) :self)) + (!rdfs:subPropertyOf + '(:rep* !rdfs:subPropertyOf)) + (t + path))) + +(define-rewrite-function rewrite-path-for-subproperties (path db) + (let ((props (db-get-values db path (subprop-query db)))) + (if (rest props) + `(:or ,@props) + (first props)))) + +(defvar *rule-rewrite-change-p*) + +(define-rewrite-function rewrite-path-using-rules (path db) + (let ((new-path (gethash path *known-rewrite-rules*))) + (cond (new-path + (setf *rule-rewrite-change-p* t) + new-path) + (t + path)))) + +(defun rewrite-path-using-rule-engine (path db) + ;; Keep rewriting until nothing changes... + (loop (let ((*rule-rewrite-change-p* nil)) + (setf path (rewrite-path-using-rules path db)) + (unless *rule-rewrite-change-p* + (return-from rewrite-path-using-rule-engine path))))) + +(defun subprop-query (db) + (or *subprop-query* + (progn + (clrhash *rewritten-paths*) + (setf *subprop-query* + (make-instance 'path + :db db + :expression `(:rep* (:inv (:or ,@*subprops-of-subprop*)))))))) + +(defun db-collect-rewrite-rules (db) + (clrhash *known-rewrite-rules*) + (dolist (rule (db-get-values db !wilbur:Rule '(:inv !rdf:type))) + (setf (gethash rule *known-rewrite-rules*) + (cond ((db-node-type-p db rule !wilbur:PathRewriteRule) + (read-from-string + (literal-string (first (db-get-values db rule !wilbur:path))))) + ((db-node-type-p db rule !wilbur:AccessDaemon) + (make-access-daemon rule)))))) + +(defun db-clear-reasoner-cache (db) + ;;(when (typep db 'pre-rewrite-cached-access-mixin) + ;; (db-clear-cache db)) + (clrhash (db-path-fsas db)) + (clrhash *rewritten-paths*) + (setf *subprop-query* nil) + (db-update-ifps db)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CONVENIENCE CLASS EDB +;;; + +(defclass edb (deductive-closure-db-mixin interned-literal-indexed-db) + ()) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; TYPE HIERARCHY ANALYSIS +;;; + +(defmethod db-node-type-p ((db deductive-closure-db-mixin) (node node) (type node)) + (frames-related-p node !rdf:type type *db* nil)) + +(defmethod db-node-subtype-p ((db deductive-closure-db-mixin) + (type node) (supertype node)) + (frames-related-p type !rdfs:subClassOf supertype db nil)) + +(defmethod db-node-types ((db db) (node node)) + (sort-types (db-get-values db node !rdf:type) db)) + +(defun sort-types (types db &key (key #'identity)) + (sort types + #'(lambda (c1 c2) + (db-node-subtype-p db c1 c2)) + :key key)) + +(defmethod db-node-types-expanded ((db db) (node node)) + (labels ((partition (type other-types) + (let* ((supers (sort-types (db-get-values db type '(:rep* !rdfs:subClassOf)) + db)) + (others (remove-if #'(lambda (type) + (member type supers)) + other-types))) + (if others + (cons supers (partition (first others) (rest others))) + (list supers))))) + (let ((types (db-node-types db node))) + (when types + (partition (first types) (rest types)))))) + +(defmethod db-node-types-expanded ((db deductive-closure-db-mixin) (node node)) + (labels ((partition (type other-types) + (let* ((supers (sort-types (db-get-values db type !rdfs:subClassOf) db)) + (others (remove-if #'(lambda (type) + (member type supers)) + other-types))) + (if others + (cons supers (partition (first others) (rest others))) + (list supers))))) + (let ((types (db-node-types db node))) + (when types + (partition (first types) (rest types)))))) + +(defmethod db-node-properties ((db deductive-closure-db-mixin) (node node)) + (let ((triples (make-triple-collection (db-query db node nil nil))) + (sameas (gethash node (db-sameas-clusters db)))) + (flet ((add-queried-triples (prop) + (dolist (value (db-get-values db node prop)) + (triple-collection-add triples (db-make-triple db node prop value))))) + (add-queried-triples !rdf:type) + (add-queried-triples !rdfs:subClassOf) + (add-queried-triples !rdfs:subPropertyOf) + (dolist (n sameas) + (unless (eq n node) + (triple-collection-add triples (db-make-triple db node !owl:sameAs n)))) + (triple-collection-triples triples)))) + +(defmethod db-node-properties-partitioned ((db deductive-closure-db-mixin) (node node) + &aux (hintsp nil)) + (let ((types (db-node-types-expanded db node)) + (triples (make-triple-collection)) + (sameas (pushnew node (gethash node (db-sameas-clusters *db*))))) + (labels ((add-queried-properties (n property exclude) + (dolist (value (db-get-values db n property)) + (unless (find value exclude) + (triple-collection-add triples (triple node property value))))) + (collect-properties (n) + (dolist (triple (db-query db n nil nil)) + (unless (eq (triple-predicate triple) !owl:sameAs) + (triple-collection-add triples triple))) + (add-queried-properties n !rdf:type '(!rdfs:Resource)) + (add-queried-properties n !rdfs:subClassOf sameas) + (add-queried-properties n !rdfs:subPropertyOf sameas)) + (triple~ (a b) + (and (eq (triple-predicate a) (triple-predicate b)) + (eq (triple-object a) (triple-object b))))) + (dolist (n sameas) + (collect-properties n)) + (let ((properties + (remove-duplicates (triple-collection-triples triples) :test #'triple~))) + (flet ((construct-property-sets (some-types) + (let ((props nil) + (type-props nil) + (used-types nil)) + (dolist (property properties) + (let ((p (triple-predicate property)) + (o (triple-object property))) + (cond ((and (eq p !rdf:type) + (find o some-types)) + (push property type-props) + (removef some-types o) + (push o used-types) + (removef properties property)) + ((and (not (eq (first (db-get-values db p !rdfs:domain)) + !rdfs:Resource)) + (some #'(lambda (type) + (unless (eq type !rdfs:Resource) + (frames-related-p p !rdfs:domain type + db nil))) + (append used-types some-types))) + (push property props) + (removef properties property))))) + (if hintsp + `(:types ,(sort-types (mapcar #'triple-object type-props) db) + :properties ,props) + (append (sort-types type-props db :key #'triple-object) props))))) + (append (mapcar #'construct-property-sets types) + (list (if hintsp + `(:types (!rdfs:Resource) :properties ,properties) + (cons (db-make-triple db node !rdf:type !rdfs:Resource) + properties))))))))) + +(defmethod db-node-properties :around ((db deductive-closure-db-mixin) (node node)) + (let ((nodes (gethash node (db-sameas-clusters db)))) + (if nodes + (reduce #'(lambda (x y) + (union x y :test #'triple=)) + (mapcar #'(lambda (n) + (call-next-method db n)) + nodes)) + (call-next-method)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; INVERSE FUNCTIONAL PROPERTIES +;;; +;;; This is a hack, and will go away at some point when we figure out a better way to +;;; do inverse functional properties. In the meantime, I am sorry. +;;; + +(defmethod db-update-single-ifp ((db deductive-closure-db-mixin) (ifp node) + &optional (obj-subj-map (make-hash-table :test #'eq))) + (let ((additions (db-ifp-additions db))) + (dolist (triple (db-query db nil ifp nil)) + (push (triple-subject triple) (gethash (triple-object triple) obj-subj-map))) + (maphash #'(lambda (value nodes) + (declare (ignore value)) + (when (rest nodes) + (let ((root (first nodes))) + (dolist (node (rest nodes)) + (let ((triple (db-make-triple db root !owl:sameAs node))) + (db-add-triple db triple) + (triple-collection-add additions triple)))))) + obj-subj-map))) + +(defmethod db-update-ifps ((db deductive-closure-db-mixin)) + (dolist (triple (triple-collection-triples (db-ifp-additions db))) + (let ((triple (db-find-triple db triple))) + (unless (triple-sources triple) + (db-del-triple db triple)))) + (triple-collection-clear (db-ifp-additions db)) + (let ((obj-subj-map (make-hash-table :test #'eq))) + (dolist (ifp (db-get-values db !owl:InverseFunctionalProperty '(:inv !rdf:type))) + (clrhash obj-subj-map) + (db-update-single-ifp db ifp obj-subj-map)))) diff --git a/src/core/transaction.lisp b/src/core/transaction.lisp new file mode 100644 index 0000000..b599077 --- /dev/null +++ b/src/core/transaction.lisp @@ -0,0 +1,126 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; transaction.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Transaction functionality for triple store databases +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; + +(defclass transaction-db-mixin () + ((transaction-lock + :initform (make-lock) + :reader db-transaction-lock) + (transaction-level + :initform 0 + :accessor db-transaction-level))) + +(defmacro with-transaction-lock (db &body body) + `(with-lock ((db-transaction-lock ,db)) ,@body)) + +(defmacro with-transaction (db &key form commit rollback) + (with-temps (d abortp) + `(let ((,d ,db)) + (with-transaction-lock ,d + (unwind-protect (let ((,abortp t)) + (incf (db-transaction-level ,d)) + (prog1 ,form + (setf ,abortp nil))) + (when (zerop (decf (db-transaction-level ,d))) + (if ,abortp ,rollback ,commit))))))) + +(defmethod db-add-triple :around ((db locked-db-mixin) (triple triple)) + (with-triple-lock db + (call-next-method))) + +(defmethod db-del-triple :around ((db locked-db-mixin) (triple triple) &optional source) + (declare (ignore source)) + (with-triple-lock db + (call-next-method))) + +(defmethod db-merge :around ((to locked-db-mixin) (from db) &optional source) + (declare (ignore source)) + (with-triple-lock to + (call-next-method))) diff --git a/src/core/wilbur-ql.lisp b/src/core/wilbur-ql.lisp new file mode 100644 index 0000000..2447cf8 --- /dev/null +++ b/src/core/wilbur-ql.lisp @@ -0,0 +1,643 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; wilbur-ql.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file implements the Wilbur Query Language (WilburQL) which essentially +;;; is a simple API on top of the RDF data manager (in "core-data.lisp"). Much of the +;;; functionality is modeled after the BEEF frame system: +;;; +;;; Ora Lassila: "BEEF Reference Manual - A Programmer's Guide to the BEEF Frame +;;; System", Second Version, Report HTKK-TKO-C46, Otaniemi (Finland), Department of +;;; Computer Science, Helsinki University of Technology, 1991 +;;; +;;; Juha Hynynen and Ora Lassila: "On the Use of Object-Oriented Paradigm in a +;;; Distributed Problem Solver", AI Communications 2(3): 142-151 (1989) +;;; +;;; A description of the WilburQL itself can be found in the following paper: +;;; +;;; Ora Lassila: "Taking the RDF Model Theory Out for a Spin", in: Ian Horrocks & +;;; James Hendler (eds.): "The Semantic Web - ISWC 2002", Lecture Notes in Computer +;;; Science 2342, pp.307-317, Springer Verlag, 2002 +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS PATH +;;; +;;; The path grammar implementation is derived from BEEF frame system. +;;; + +(defclass path () + ((expression + :accessor path-expression) + (db + :initarg :db + :reader path-db) + (fsa + :accessor path-fsa))) + +(defmethod print-object ((path path) stream) + (print-unreadable-object (path stream :type t) + (prin1 (path-expression path) stream))) + +(defmethod initialize-instance :after ((self path) &rest args &key expression) + (declare (ignore args)) + (multiple-value-bind (fsa expression) + (db-make-path-fsa (path-db self) expression) + (setf (path-fsa self) fsa + (path-expression self) expression))) + +(defmethod invert ((path path)) + (make-instance 'path + :db (path-db path) + :expression (invert-path (path-expression path)))) + +(defstruct (path-node + (:conc-name pn-) + (:copier nil) + (:constructor new-pn (link))) + (link nil :read-only t) ; slot name i.e. link in the path + (follows nil)) ; possible followers of this node + +(defstruct (path-fsa-state + (:conc-name ps-) + (:copier nil) + (:constructor new-ps (positions))) + (positions nil :read-only t) ; positions defining this state + (transitions nil)) ; transitions from this state + +(defstruct (path-fsa-transition + (:conc-name pt-) + (:copier nil) + (:constructor new-pt (input index))) + (input nil :read-only t) ; input symbol (= predicate name) + (index nil :read-only t)) ; index of the target state + +(defmethod print-object ((self path-fsa-transition) stream) + (print-unreadable-object (self stream :type t) + (let ((input (pt-input self))) + (typecase input + (inverse-slot + (format stream ":inv ~S->~D" (inverse-slot-node input) (pt-index self))) + (node + (format stream "~S->~D" input (pt-index self))) + (default-value + (format stream "(:value ~S)->~D" (default-value-value input) (pt-index self))) + (t + (format stream "~S->~D" input (pt-index self))))))) + +(defun canonical-path (expr) + (db-canonical-path *db* expr)) + +(defmethod db-canonical-path-op ((db db) op &rest args) + (declare (ignore op args)) + nil) + +(defmethod db-canonical-path ((db db) expr) + (labels ((canonical (expr) + (etypecase expr + (cons + (destructuring-bind (op arg &rest args) expr + (if arg + (case op + ((:rep* :rep+ :inv :value :filter :restrict + :lang :test :daemon :norewrite) + (assert (null args) nil "Extra operands for ~S in ~S" op expr) + (case op + (:rep+ (canonical `(:seq ,arg (:rep* ,arg)))) + (:rep* `(,op ,(canonical arg))) + (:inv (canonical (invert-path arg))) + (:value (make-default-value arg)) + (:filter (make-instance 'path-uri-filter :key arg)) + (:restrict (make-instance 'path-node-restriction :key arg)) + (:lang (make-instance 'path-lang-filter :key arg)) + (:test (make-instance 'functional-restriction :key arg)) + (:daemon (make-access-daemon arg)) + (:norewrite (canonical arg)))) + ((:seq :seq+ :or) + (if args + (let ((arg (canonical arg))) + (unless (or (atom arg) (not (eq op (first arg)))) + (psetq arg (second arg) + args (append (cddr arg) args))) + (cond ((rest args) + (canonical `(,op ,arg (,op ,@args)))) + ((eq op :or) + `(,op ,(canonical (first args)) + ,(canonical arg))) + (t + `(,op ,(canonical arg) + ,(canonical (first args)))))) + (canonical arg))) + (t + (or (apply #'db-canonical-path-op db op + (mapcar #'canonical (cons arg args))) + (error "Unknown query operator ~S" op)))) + (error 'query-syntax-error :thing op)))) + (string + (node expr)) + (keyword + (assert (member expr '(:members :any + :predicate-of-object :predicate-of-subject :self))) + expr) + ((or node inverse-slot default-value path-filter access-daemon) + expr) + (symbol + (error "Symbol ~S not allowed as a path expression" expr))))) + (canonical expr))) + +(defun invert-path (expr &optional (canonicalizep nil)) + (labels ((remove-defaults (x) + (remove-if #'(lambda (y) + (typecase y + (default-value t) + (cons (eq (car y) :value)))) + x)) + (i (p) + (etypecase p + (cons + (ecase (first p) + (:or + `(,(first p) + ,@(mapcar #'i (reverse (remove-defaults (rest p)))))) + ((:seq :seq+) + `(,(first p) ,@(mapcar #'i (reverse (remove-defaults (rest p)))))) + ((:rep* :rep+) ; REP+ added, is this correct? + `(,(first p) ,(i (second p)))) + (:inv + (second p)))) + (node + (make-inverse-slot p)) + (inverse-slot + (inverse-slot-node p)) + (keyword + (if (eq p :self) :self (make-inverse-slot p))) + (default-value + (error 'cannot-invert-default-value :thing (default-value-value p))) + (path-filter + p)))) + (i (if canonicalizep (canonical-path expr) expr)))) + +(defun make-path-fsa (expr) + (warn "Use of MAKE-PATH-FSA is deprecated. Use DB-MAKE-PATH-FSA instead.") + (db-make-path-fsa *db* expr)) + +(defmethod db-make-path-fsa ((db db) expr &aux e) + (when expr + (let ((path-fsas (db-path-fsas db))) + (values (or (gethash expr path-fsas) + (setf e (db-canonical-path db expr) + (gethash expr path-fsas) (db-construct-new-path-fsa db e))) + e)))) + +(defvar *fsa-states/temporary* (make-array 8 :adjustable t :fill-pointer 0)) + +(defun construct-new-path-fsa (expr) + (declare (ignore expr)) + (error "Use of CONSTRUCT-NEW-PATH-FSA is deprecated.")) + +(defmethod db-construct-new-path-fsa ((db db) expr &aux inputs) + (labels ((decorate (x) + (if (atom x) + (let ((node (list (new-pn x)))) + (pushnew x inputs) + (values node node nil)) + (case (pop x) + (:seq (multiple-value-bind (first1 last1 null1) (decorate (first x)) + (multiple-value-bind (first2 last2 null2) (decorate (second x)) + (add-followers last1 first2) + (values (if null1 (union first1 first2) first1) + (if null2 (union last1 last2) last2) + (and null1 null2))))) + (:seq+ (multiple-value-bind (first1 last1 null1) (decorate (first x)) + (multiple-value-bind (first2 last2) (decorate (second x)) + (add-followers last1 first2) + (values (if null1 (union first1 first2) first1) + (union last1 last2) + null1)))) + (:or (multiple-value-bind (first1 last1 null1) (decorate (first x)) + (multiple-value-bind (first2 last2 null2) (decorate (second x)) + (values (union first1 first2) + (union last1 last2) + (or null1 null2))))) + (:rep* (multiple-value-bind (first last) (decorate (first x)) + (add-followers last first) + (values first last t)))))) + (add-followers (from to) + (dolist (i from) (unionf (pn-follows i) to))) + (add-state (positions) + (or (position positions *fsa-states/temporary* + :key #'ps-positions + :test #'(lambda (x y) + (and (subsetp x y) (subsetp y x)))) + (vector-push-extend (new-ps positions) *fsa-states/temporary*)))) + (setf (fill-pointer *fsa-states/temporary*) 0) + (add-state (decorate `(:seq ,expr nil))) + (do ((i 0 (1+ i))) + ((= i (length *fsa-states/temporary*))) + (let ((state (elt *fsa-states/temporary* i))) + (dolist (input inputs) + (let ((positions nil)) + (dolist (p (ps-positions state)) + (when (eq (pn-link p) input) + (unionf positions (pn-follows p)))) + (when positions + (let ((index (add-state positions))) + (when input + (push (new-pt input index) (ps-transitions state))))))))) + (map 'simple-vector #'(lambda (s) + (cons (and (member nil (ps-positions s) :key #'pn-link) t) + (reverse (ps-transitions s)))) + *fsa-states/temporary*))) + +(defmacro with-hash-pool ((var pool) &body body) + `(let* ((,pool ,pool) + (,var (clrhash (or (pop ,pool) (make-hash-table :test #'eq))))) + (unwind-protect (progn ,@body) + (clrhash ,var)))) + +(defvar *walk-states/temporary* (list (make-hash-table :test #'eq) + (make-hash-table :test #'eq) + (make-hash-table :test #'eq))) + +(defvar *collect-nodes/temporary* (list (make-hash-table :test #'eq) + (make-hash-table :test #'eq) + (make-hash-table :test #'eq))) + +(defun walk-using-fsa (root fsa action db) + (with-hash-pool (states *walk-states/temporary*) + (labels ((walk (f i) + (unless (member i (gethash f states) :test #'=) + (push i (gethash f states)) + (let ((transitions (svref fsa i))) + (or (when (first transitions) + (funcall action f)) + (when (or (typep f 'node) (typep f 'literal) (null f)) + ;;(when (typep f 'node) + (dolist (link (rest transitions)) + (dolist (v (db-get-values db f (pt-input link))) + (let ((values (walk v (pt-index link)))) + (when values + (return-from walk-using-fsa values))))))))))) + (declare (dynamic-extent #'walk)) + (when fsa + (walk root 0))))) + +(defun walk-using-fsa-remembering-path (root fsa action db) + (with-hash-pool (states *walk-states/temporary*) + (labels ((walk (f i pn pp) + ;; (format t "~&WALK: ~S ~S ~S ~S ~S" f i pn pp (gethash f states)) + (unless (member i (gethash f states) :test #'=) + (push i (gethash f states)) + ;; (format t "~&PUSH: ~S ~S" f i) + (let ((transitions (svref fsa i)) + (pn (cons f pn))) + (or (when (first transitions) + (funcall action f pn pp)) + (when (typep f 'node) + (dolist (link (rest transitions)) + (multiple-value-bind (values predicates) + (db-get-values db f (pt-input link)) + (assert (= (length values) (length predicates))) + (loop for v in values + for p in predicates + do (progn + ;; (format t "~&LOOP: ~S ~S" v p) + (let ((values (walk v (pt-index link) + pn (cons p pp)))) + (when values + (return-from walk-using-fsa-remembering-path + values))))))))))))) + (declare (dynamic-extent #'walk)) + (when fsa + (walk root 0 nil nil))))) + +(defun collect-using-fsa (root fsa db) + (with-hash-pool (node-hash *collect-nodes/temporary*) + (let ((nodes nil)) + (flet ((collect-results (n) + (unless (gethash n node-hash) + (setf (gethash n node-hash) t) + (push n nodes) + nil))) + (declare (dynamic-extent #'collect-results)) + (walk-using-fsa root fsa #'collect-results db) + (nreverse nodes))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; STRUCTURE CLASS INVERSE-SLOT +;;; STRUCTURE CLASS DEFAULT-VALUE +;;; + +(defvar *inverse-slots* (make-hash-table :test #'eq)) + +(defun make-inverse-slot (node) + (or (gethash node *inverse-slots*) + (setf (gethash node *inverse-slots*) (%make-inverse-slot node)))) + +(defstruct (inverse-slot + (:copier nil) + (:constructor %make-inverse-slot (node))) + node) + +(defmethod print-object ((self inverse-slot) stream) + (print-unreadable-object (self stream :type t) + (let ((node (inverse-slot-node self))) + (if (typep node 'node) + (multiple-value-bind (name shortp) + (find-short-name *nodes* (node-uri (inverse-slot-node self))) + (format stream (if shortp "!~A" "!~S") name)) + (prin1 node stream))))) + +(defstruct (default-value + (:copier nil) + (:constructor make-default-value (value))) + value) + +(defmethod print-object ((self default-value) stream) + (print-unreadable-object (self stream :type t) + (prin1 (default-value-value self) stream))) + + +(defstruct (access-daemon + (:copier nil) + (:constructor make-access-daemon (property))) + property) + +(defmethod print-object ((self access-daemon) stream) + (print-unreadable-object (self stream :type t) + (prin1 (access-daemon-property self) stream))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS PATH-FILTER +;;; CLASS PATH-URI-FILTER +;;; CLASS FUNCTIONAL-RESTRICTION +;;; + +(defclass path-filter () + ((key + :initarg :key + :reader path-filter-key))) + +(defmethod print-object ((self path-filter) stream) + (print-unreadable-object (self stream :type t) + (prin1 (path-filter-key self) stream))) + +(defgeneric path-filter-match-p (filter node)) + +(defmethod path-filter-match-p ((filter path-filter) node) + (declare (ignore node)) + nil) + +(defclass path-uri-filter (path-filter) + ()) + +(defmethod path-filter-match-p ((filter path-uri-filter) (node node)) + (name-contains-pattern-p (node-uri node) (path-filter-key filter))) + +(defmethod path-filter-match-p ((filter path-uri-filter) (literal literal)) + (name-contains-pattern-p (literal-string literal) (path-filter-key filter))) + +(defclass path-lang-filter (path-filter) + ()) + +(defmethod path-filter-match-p ((filter path-lang-filter) (literal literal)) + (let ((key (path-filter-key filter)) + (lang (literal-language literal))) + (cond ((null lang) + (null key)) + (key + (let ((n (length key))) + (and (<= n (length lang)) + (string= key lang :end2 n))))))) + +(defclass path-node-restriction (path-filter) + ()) + +(defmethod path-filter-match-p ((filter path-node-restriction) (node node)) + (eq node (path-filter-key filter))) + +(defmethod path-filter-match-p ((filter path-node-restriction) (node null)) + t) + +(defmethod path-filter-match-p ((filter path-node-restriction) (literal literal)) + nil) + +(defclass functional-restriction (path-filter) + ()) + +(defmethod path-filter-match-p ((filter functional-restriction) node) + (funcall (path-filter-key filter) node)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS NODE (FRAME SYSTEM API ADDITIONS) +;;; + +;; It is difficult to use EQL-specializers here, since the reasoner may rewrite path +;; expressions and thus change the applicable methods list on the fly... +(defmethod db-get-values ((db db) (frame literal) path) + (if (eq path !rdf:type) + (let ((datatype (literal-datatype frame))) + (if datatype + (list datatype !rdf:XMLLiteral !rdfs:Resource) + (list !rdfs:Literal !rdfs:Resource))) + (call-next-method))) + +(defun collect-inverse-members (node db) + (mapcan #'(lambda (u) + (mapcar #'triple-subject (db-query db nil u node))) + (coerce *index-uris* 'list))) + +(defun db-extract (db frame path triples key) + (declare (ignore db frame path)) + (when triples + (mapcar key triples))) + +(defmethod db-get-values ((db db) frame path + &aux (f (if (eq frame :all) nil frame))) + ;; Here's where Wilbur spends its time... + (etypecase path + (node (mapcar #'triple-object (db-query db f path nil))) + (inverse-slot (let ((slot (inverse-slot-node path))) + (etypecase slot + (node + (mapcar #'triple-subject (db-query db nil slot f))) + (symbol + (ecase slot + (:predicate-of-object + (mapcar #'triple-object (db-query db nil f nil))) + (:predicate-of-subject + (mapcar #'triple-subject (db-query db nil f nil))) + (:members + (collect-inverse-members f db)) + (:any + (mapcar #'triple-subject (db-query db nil nil f)))))))) + (path (collect-using-fsa f (path-fsa path) db)) + (symbol (ecase path + (:predicate-of-object + (mapcar #'triple-predicate + (remove-duplicates (db-query db nil nil f) + :key #'triple-predicate))) + (:predicate-of-subject + (mapcar #'triple-predicate + (remove-duplicates (db-query db f nil nil) + :key #'triple-predicate))) + (:self + (list f)) + (:members + (loop for i from 1 + for v = (first (db-get-values db f (node (index-uri i db)))) + while v collect v)) + (:any + (mapcar #'triple-object (db-query db f nil nil))))) + (default-value (list (default-value-value path))) + (cons (collect-using-fsa f (db-make-path-fsa db path) db)) + (path-filter (and (path-filter-match-p path f) + (list (or f (path-filter-key path))))) + (access-daemon (db-compute-daemon-values db f (access-daemon-property path))))) + +(defmethod db-compute-daemon-values ((db db) frame slot) + (case slot + (!wilbur:timeStamp + (list (db-make-literal db (iso8601-date-string (get-universal-time)) + :datatype !xsd:dateTime))) + (!wilbur:tripleCount + (when (find frame (db-sources db)) + (list (db-make-literal db (prin1-to-string (length (db-query-by-source db frame))) + :datatype !xsd:integer)))))) + +(defmethod frames-related-p ((source node) + path + (sink node) + (db db) + action) + (%frames-related-p source path sink db action)) + +(defun %frames-related-p (source path sink db action) + ;; this does not do any reasoning! + (typecase path + (node + (not (null (db-query db source path sink)))) + (inverse-slot + (frames-related-p sink (inverse-slot-node path) source db action)) + (cons + (frames-related-p source (make-instance 'path :db db :expression path) + sink db action)) + (path + (flet ((is-sink-p (node) + (when action + (funcall action node)) + (eq node sink))) + (declare (dynamic-extent #'is-sink-p)) + (walk-using-fsa source (path-fsa path) #'is-sink-p db))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS RESUMABLE-QUERY +;;; + +(defclass resumable-query () + ((results + :initarg :results + :initform nil + :accessor resumable-query-results))) + +(defmethod db-get-values-resumable ((db db) frame path + &key (resumable-query (db-get-values db frame path)) + (count most-positive-fixnum)) + (let* ((results (resumable-query-results resumable-query)) + (n (length results))) + (cond ((> count n) + (let ((head (subseq results 0 count))) + (setf (resumable-query-results resumable-query) + (subseq results count)) + (values head resumable-query))) + (t + (setf (resumable-query-results resumable-query) nil) + (values results nil))))) diff --git a/src/goodies/#source-engine.lisp# b/src/goodies/#source-engine.lisp# new file mode 100644 index 0000000..e37a91e --- /dev/null +++ b/src/goodies/#source-engine.lisp# @@ -0,0 +1,44 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The contents of this file are subject to the NOKOS License Version 1.0a (the +;;; "License"); you may not use this file except in compliance with the License. +;;; +;;; Software distributed under the License is distributed on an "AS IS" basis, WITHOUT +;;; WARRANTY OF ANY KIND, either express or implied. See the License for the specific +;;; language governing rights and limitations under the License. +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2005 Nokia and others. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Version: $Id: wilbur2-file-header.lisp,v 1.1 2004/08/10 16:24:46 ora Exp $ +;;; +;;; Purpose: +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; + +(defclass source () + ((uri + :initarg :uri + :reader source-uri))) \ No newline at end of file diff --git a/src/goodies/db-additions.lisp b/src/goodies/db-additions.lisp new file mode 100644 index 0000000..1460a0a --- /dev/null +++ b/src/goodies/db-additions.lisp @@ -0,0 +1,219 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; db-additions.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Some additional triple database functionality +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; + +(defmethod db-reify ((triple triple) (db db) + &optional (statement-uri nil) + (source nil)) + (let ((node (node statement-uri))) + (flet ((make-and-add-triple (p o) + (db-add-triple db (db-make-triple db node (node p) o source)))) + (make-and-add-triple -rdf-subject-uri- (triple-subject triple)) + (make-and-add-triple -rdf-predicate-uri- (triple-predicate triple)) + (make-and-add-triple -rdf-object-uri- (triple-object triple)) + (make-and-add-triple -rdf-type-uri- (node -rdf-statement-uri-)) + node))) + +(defmethod is-container-p ((db db) (node node) &optional errorp) + ;; We may have to extend this to handle subclasses of containers + (let ((container-types (list (node -rdf-bag-uri-) + (node -rdf-seq-uri-) + (node -rdf-alt-uri-)))) + (dolist (triple (db-query db node (node -rdf-type-uri-) nil)) + (when (find (triple-object triple) container-types) + (return-from is-container-p t))) + (when errorp + (cerror "Ignore" 'container-required :thing node)))) + +(defmethod db-find-cbd ((db db) (node node)) + ;; Calculates the Concise Bounded Description as per Patrick Stickler's spec at + ;; http://www.w3.org/Submission/2004/SUBM-CBD-20040930/ + (cbd (list node) nil nil nil db)) + +(defun cbd (nodes triples cbd-nodes cbd-triples db) + (cond (nodes + (let ((n (first nodes))) + (if (member n cbd-nodes) + (cbd (rest nodes) triples cbd-nodes cbd-triples db) + (cbd (rest nodes) + (append triples (db-query db n nil nil)) + (cons n cbd-nodes) + cbd-triples + db)))) + (triples + (let ((tr (first triples))) + (if (member tr cbd-triples) + (cbd nil (rest triples) cbd-nodes cbd-triples db) + (cbd (let ((s (triple-reified-p tr db)) + (o (triple-object tr))) + (if (and (typep o 'node) + (not (typep o 'literal)) + (null (node-uri o))) + (cons o s) + s)) + (rest triples) + cbd-nodes + (cons tr cbd-triples) + db)))) + (t + (values cbd-triples cbd-nodes)))) + +(defmethod db-node-local-properties ((db db) (node node)) + (remove-duplicates (mapcar #'triple-predicate (db-query db node nil nil)))) + +(defun triple-reified-p (triple db) + (let ((s-statements (db-query db nil !rdf:subject (triple-subject triple)))) + (when s-statements + (let ((o-statements (db-query db nil !rdf:object (triple-object triple)))) + (when o-statements + (let ((predicate (triple-predicate triple))) + (flet ((predicate-not-found (node) + (null (db-query db node !rdf:predicate predicate)))) + (declare (dynamic-extent #'predicate-not-found)) + (remove-if #'predicate-not-found + (intersection (mapcar #'triple-subject s-statements) + (mapcar #'triple-subject o-statements)))))))))) + +(defun get-some-values (frame path db index) + (assert (null index)) + (db-get-values db frame path)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; QUERY EXPRESSION MANIPULATION +;;; + +(defun merge-query-expressions (query1 query2) + (canonical-path `(:or ,(canonical-path query1) + ,(canonical-path query2)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS LITERAL-TRANSFORM-DB-MIXIN +;;; + +(defclass literal-transform-db-mixin () + ()) + +(defmethod db-make-literal ((db literal-transform-db-mixin) string + &key language datatype property) + (multiple-value-bind (string language datatype) + (db-transform-literal db string property + :language language :datatype datatype) + (call-next-method db string :language language :datatype datatype))) + +(defmethod db-transform-literal ((db literal-transform-db-mixin) string property + &key language datatype) + (declare (ignore property)) + (values string language datatype)) + +(defclass date-cleanup-db-mixin (literal-transform-db-mixin) + ()) + +(defmethod db-transform-literal ((db date-cleanup-db-mixin) string (property node) + &key language datatype) + ;; Heuristically transforms time stamps into xsd:date (or xsd:dateTime) literals. + ;; Only attempt this for dc:date and its recursive sub-properties + (if (or datatype (not (frames-related-p property !rdfs:subPropertyOf !dc:date db nil))) + (call-next-method) + (multiple-value-bind (universal-time omit-time-p) + ;; Is it an EXIF-style timestamp? + (parse-exif-date string) + (unless universal-time + ;; Is it an ISO8601 timestamp? + (multiple-value-setq (universal-time omit-time-p) + (ignore-errors (parse-iso8601-date string)))) + (if universal-time + (values (iso8601-date-string universal-time omit-time-p) + language + (if omit-time-p !xsd:date !xsd:dateTime)) + (call-next-method))))) diff --git a/src/goodies/index-and-match.lisp b/src/goodies/index-and-match.lisp new file mode 100644 index 0000000..a7cf7bd --- /dev/null +++ b/src/goodies/index-and-match.lisp @@ -0,0 +1,263 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; index-and-match.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Some additional triple database functionality. +;;; + + +(in-package "WILBUR") + + +;;; ---------------------------------------------------------------------------- +;;; +;;; MIXIN CLASS BLANK-NODE-DB-MIXIN +;;; + +(defclass blank-node-db-mixin () ; mix before class db + ((startup-time + :initform (get-universal-time) + :reader db-startup-time) + (blank-node-uri-prefix + :initarg :blank-node-uri-prefix + :initform "anon:" + :reader db-blank-node-uri-prefix) + (blank-node-index + :initform 0 + :accessor db-blank-node-index) + (blank-node->uri + :initform (make-hash-table :test #'eq) + :reader db-blank-node->uri) + (uri->blank-node + :initform (make-hash-table :test #'equal) + :reader db-uri->blank-node))) + +(defmethod db-resolve-blank-node-uri ((db blank-node-db-mixin) uri) + (gethash uri (db-uri->blank-node db))) + +(defmethod db-blank-node-uri ((db blank-node-db-mixin) (node node) &optional (createp t)) + (let ((node->uri (db-blank-node->uri db))) + (or (gethash node node->uri) + (when createp + (let ((uri (format nil "~A~X~X" + (db-blank-node-uri-prefix db) + (incf (db-blank-node-index db)) + (db-startup-time db)))) + (setf (gethash uri (db-uri->blank-node db)) node + (gethash node node->uri) uri)))))) + +(defmethod db-blank-node-uri-p ((db blank-node-db-mixin) uri) + (let ((prefix (db-blank-node-uri-prefix db))) + (string= uri prefix :end1 (length prefix)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; MIXIN CLASS INDEXED-LITERAL-DB-MIXIN +;;; + +(defclass indexed-literal-db-mixin () ; mix before class db + ((new-literals-lock + :initform (make-lock) + :reader db-new-literals-lock) + (new-literals + :initform nil + :accessor db-new-literals) + (max-string-length + :initarg :max-string-length + :initform 4 + :reader db-literal-index-max-string-length) + (min-string-length + :initarg :min-string-length + :initform 2 + :reader db-literal-index-min-string-length) + (supports-matching-p + :initform #+(or :cl-ppcre :excl) t #-(or :cl-ppcre :excl) nil + :reader db-supports-matching-p) + (index-literals-p + :initarg :index-literals-p + :initform nil + :reader db-index-literals-p) + (literal-substring-index + :initform (make-hash-table :test #'equal) + :reader db-literal-substring-index))) + +(defmethod (setf db-literal-index-get) :after ((literal interned-literal) + (db indexed-literal-db-mixin) string) + (declare (ignore string)) + (with-lock ((db-new-literals-lock db)) + (push literal (db-new-literals db)))) + +(defun db-literal-index-add-substrings (db string literal) + (let ((min (db-literal-index-min-string-length db)) + (max (db-literal-index-max-string-length db)) + (hash (db-literal-substring-index db))) + (mapl #'(lambda (s1) + (mapl #'(lambda (s2) + (when (<= min (length s2) max) + (pushnew literal + (gethash (concatenate 'string (reverse s2)) hash) + :test #'literal=))) + (reverse s1))) + (concatenate 'list string)) + literal)) + +(defmethod db-find-literals ((db indexed-literal-db-mixin) substring) + ;; Note: this function matches strings approximately (the substring is broken into + ;; segments shorter than the max indexed substring, and segments shorter than the + ;; min indexed substring are thrown away. Assumption is that this function is only + ;; used to perform initial filtering for an implementation of (say) a regexp match. + (let ((min (db-literal-index-min-string-length db)) + (max (db-literal-index-max-string-length db)) + (n (length substring)) + (hash (db-literal-substring-index db))) + (if (<= n max) + (gethash substring hash) + (reduce #'(lambda (s1 s2) + (intersection s1 s2 :test #'literal=)) + (mapcar #'(lambda (s) + (gethash s hash)) + (let ((substrings nil)) + (dotimes (i (ceiling n max)) + (let* ((j (* i max)) + (k (min (+ j max) n))) + (when (>= (- k j) min) + (push (subseq substring j k) substrings)))) + substrings)))))) + +(defmethod db-find-literals-multiple ((db indexed-literal-db-mixin) + substring &rest more-substrings) + (declare (dynamic-extent more-substrings)) + (if more-substrings + (intersection (apply #'db-find-literals-multiple db more-substrings) + (db-find-literals db substring) + :test #'literal=) + (db-find-literals db substring))) + +(defmethod db-index-literals ((db indexed-literal-db-mixin)) + (when (db-index-literals-p db) + (loop (let ((literal (with-lock ((db-new-literals-lock db)) + (pop (db-new-literals db))))) + (if literal + (db-literal-index-add-substrings db (literal-string literal) literal) + (return-from db-index-literals)))))) + +(defun convert-match-pattern (pattern) + (let* ((chars nil) + (strings (mapcan #'(lambda (c) + (cond ((char= c #\*) + (list (concatenate 'string + (nreverse (shiftf chars nil))) + nil)) + ((= (char-code c) 0) + (when chars + (list (concatenate 'string (nreverse chars))))) + (t + (push c chars) + nil))) + (concatenate 'list pattern (string (code-char 0)))))) + (values (remove-if #'(lambda (s) + (or (null s) + (< (length s) 2))) + strings) + (apply #'concatenate 'string (mapcar #'(lambda (s) + (or s ".*")) + strings))))) + +#+(and :cl-ppcre (not :excl)) +(defmethod db-match-literals ((db indexed-literal-db-mixin) (pattern string)) + (multiple-value-bind (substrings pattern) + (convert-match-pattern pattern) + (let ((regexp (cl-ppcre:create-scanner pattern))) + (remove-if-not #'(lambda (literal) + (cl-ppcre:all-matches regexp (literal-string literal))) + (apply #'db-find-literals-multiple db substrings))))) + +#+(and :excl (not :cl-ppcre)) +(defmethod db-match-literals ((db indexed-literal-db-mixin) (pattern string)) + (multiple-value-bind (substrings pattern) + (convert-match-pattern pattern) + (let ((regexp (compile-regexp pattern))) + (remove-if-not #'(lambda (literal) + (match-regexp regexp (literal-string literal))) + (apply #'db-find-literals-multiple db substrings))))) + +#-(or :cl-ppcre :excl) +(defmethod db-match-literals ((db indexed-literal-db-mixin) (pattern string)) + (declare (ignore db pattern)) + nil) diff --git a/src/goodies/ivanhoe.lisp b/src/goodies/ivanhoe.lisp new file mode 100644 index 0000000..2e395bb --- /dev/null +++ b/src/goodies/ivanhoe.lisp @@ -0,0 +1,150 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; ivanhoe.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: The old "db-hiding" frame API ("Ivanhoe") is grandfathered here. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; OLD "TOP-LEVEL" API +;;; + +(defvar *db* nil) ; "current" database + +(defun triple (subject predicate object &optional source) + (db-make-triple *db* subject predicate object source)) + +(defun add-triple (triple) + (db-add-triple *db* triple)) + +(defun del-triple (triple) + (db-del-triple *db* triple)) + +(defun query (subject predicate object) + (db-query *db* subject predicate object)) + +(defun reify (triple &key (statement-uri nil) (source nil)) + (db-reify triple *db* statement-uri source)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; FRAME SYSTEM API IMPLEMENTATION +;;; + +(defun frame (uri &rest slot/value-pairs) + (let ((frame (node uri))) + (dolist (slot/value-pair slot/value-pairs) + (destructuring-bind (slot . value) slot/value-pair + (add-value frame slot value))) + frame)) + +(defun own-slots (frame) + (remove-duplicates (mapcar #'triple-predicate (db-query *db* frame nil nil)))) + +(defun value (frame &rest paths) + (declare (dynamic-extent paths)) + (flet ((v (path) (get-value frame path *db*))) + (declare (dynamic-extent #'v)) + (apply #'values (mapcar #'v paths)))) + +(defun all-values (frame &rest paths) + (declare (dynamic-extent paths)) + (flet ((av (path) (get-all-values frame path *db*))) + (declare (dynamic-extent #'av)) + (apply #'values (mapcar #'av paths)))) + +(defun add-value (frame path value) + (db-add-triple *db* (db-make-triple *db* frame path value)) + value) + +(defun del-value (frame path &optional value) + (dolist (triple (db-query *db* frame path value)) + (db-del-triple *db* triple))) + +(defun relatedp (source path sink &optional action) + (frames-related-p source path sink *db* action)) + +(defun load-db (source &rest options) + (declare (dynamic-extent options)) + (apply #'db-load *db* source options)) diff --git a/src/goodies/literal-transforms.lisp b/src/goodies/literal-transforms.lisp new file mode 100644 index 0000000..15f8223 --- /dev/null +++ b/src/goodies/literal-transforms.lisp @@ -0,0 +1,105 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; literal-transforms.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Interface to load/creation-time literal transformation framework. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS LITERAL-TRANSFORM-DB-MIXIN +;;; + +(defclass literal-transform-db-mixin () + ()) + +(defmethod db-make-literal ((db literal-transform-db-mixin) string + &key language datatype property) + (multiple-value-bind (string language datatype) + (db-transform-literal db string property + :language language :datatype datatype) + (call-next-method db string :language language :datatype datatype))) + +(defmethod db-transform-literal ((db literal-transform-db-mixin) string property + &key language datatype) + (declare (ignore property)) + (values string language datatype)) diff --git a/src/goodies/rdf-inspector.lisp b/src/goodies/rdf-inspector.lisp new file mode 100644 index 0000000..5db663e --- /dev/null +++ b/src/goodies/rdf-inspector.lisp @@ -0,0 +1,374 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; rdf-inspector.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains various kinds of functionality for visualizing as well +;;; as browsing RDF data and WilburQL queries (using the MCL Inspector, PowerGrapher +;;; and GraphWiz). +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS NODE-INSPECTOR +;;; +;;; Extension of the MCL Inspector to allow browsing of RDF graphs. +;;; + +(defclass node-inspector (inspector::usual-inspector) + ((out-links + :accessor inspector-out-links) + (in-links + :accessor inspector-in-links))) + +(defmethod inspector::inspector-class ((node node)) + 'node-inspector) + +(defmethod initialize-instance :after ((i node-inspector) &rest args) + (declare (ignore args)) + (flet ((sort-triples (triples) + (sort (copy-list triples) #'string< + :key #'(lambda (x) + (node-uri (triple-predicate x)))))) + (let ((node (inspector::inspector-object i))) + (setf (inspector-out-links i) (sort-triples (query node nil nil)) + (inspector-in-links i) (sort-triples (query nil nil node)))))) + +(defmethod inspector::compute-line-count ((i node-inspector)) + (+ (length (inspector-out-links i)) (length (inspector-in-links i)) 3)) + +(defmethod inspector::line-n ((i node-inspector) n) + (let ((node (inspector::inspector-object i)) + (k (+ (length (inspector-out-links i)) 2))) + (cond ((zerop n) + (values (node-uri node) "URI" :colon)) + ((= n 1) + (values nil "Properties" :comment)) + ((< n k) + (let ((triple (elt (inspector-out-links i) (- n 2)))) + (values (triple-object triple) + (node-name (triple-predicate triple)) + :colon))) + ((= n k) + (values nil "Incoming" :comment)) + (t + (let ((triple (elt (inspector-in-links i) (- n k 1)))) + (values (triple-subject triple) + (node-name (triple-predicate triple)) + :colon)))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS RDF-CLASS-TREE +;;; CLASS RDF-CLASS-NODE +;;; +;;; Extension of PowerGrapher to allow visualization of RDF graphs and class trees. +;;; + +(defclass rdf-class-tree (pg:tree) + ()) + +(defmethod pg:compute-root-nodes ((self rdf-class-tree) + &key root (level most-positive-fixnum) + &allow-other-keys) + (let ((class (node root))) + (list (pg:make-node self 'rdf-class-node class level nil :class class)))) + +(defclass rdf-class-node (wu:selectable-rectangle-mixin pg:text-node) + ((class + :initarg :class + :reader pg:node-key))) + +(defmethod pg:compute-node-text ((self rdf-class-node)) + (find-short-name *nodes* (node-uri (pg:node-key self)))) + +(defmethod pg:compute-node-children ((self rdf-class-node) level) + (mapcar #'(lambda (triple) + (let ((class (triple-subject triple))) + (pg:make-node (pg:node-collection self) + (class-of self) class level self + :class class))) + (query nil !rdfs:subClassOf (pg:node-key self)))) + +(defmethod wu:item-action ((self rdf-class-node)) + (inspect (pg:node-key self))) + +(defun make-rdf-class-tree (root &rest args) + (declare (dynamic-extent args)) + (apply #'make-instance 'pg:tree-window + :root root + :window-title (find-short-name *nodes* (node-uri root)) + :tree-class 'rdf-class-tree + args)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS RDF-QUERY-TREE +;;; +;;; Extension of PowerGrapher to allow visualization of WQL queries. +;;; + +(defclass rdf-query-tree (pg:tree) + ((children + :initform nil + :accessor tree-children) + (terminal-nodes + :initform nil + :accessor tree-terminal-nodes))) + +(defmethod pg:compute-root-nodes ((self rdf-query-tree) + &key root (level most-positive-fixnum) query + &allow-other-keys) + (let ((n (node root)) + (children (make-hash-table :test #'eq)) + (terminal-nodes nil)) + (instrumented-walk-using-fsa n (make-path-fsa query) + #'(lambda (node terminalp transitions) + (when terminalp + (pushnew node terminal-nodes)) + (dolist (tr transitions) + (dolist (value (db-get-slot-values *db* node + (pt-input tr))) + (pushnew value (gethash node children)))) + nil) + *db*) + (setf (tree-children self) children + (tree-terminal-nodes self) terminal-nodes) + (list (pg:make-node self 'rdf-query-node n level nil :node n)))) + +(defclass rdf-query-node (pg:text-node) + ((node + :initarg :node + :reader pg:node-key) + (terminalp + :initarg :terminalp + :reader node-terminal-p))) + +(defmethod view-draw-contents :after ((self rdf-query-node)) + (when (member (pg:node-key self) (tree-terminal-nodes (pg:node-collection self))) + (wu:draw-rect self #@(1 1) (subtract-points (view-size self) #@(1 1)) :black nil))) + +(defmethod pg:compute-node-children ((self rdf-query-node) level) + (let ((node (pg:node-key self)) + (tree (pg:node-collection self))) + (etypecase node + (string nil) + (node (mapcar #'(lambda (child) + (pg:make-node tree (class-of self) child level self + :node child)) + (gethash node (tree-children tree))))))) + +(defmethod pg:compute-node-text ((self rdf-query-node)) + (let ((key (pg:node-key self))) + (etypecase key + (string (format nil "~S" key)) + (node (let ((uri (node-uri key))) + (if uri + (find-short-name *nodes* uri) + (format nil "(~S)" (sxhash key)))))))) + +(defun make-rdf-query-tree (root query &rest args) + (declare (dynamic-extent args)) + (apply #'make-instance 'pg:tree-window + :root root + :query query + :tree-class 'rdf-query-tree + :window-title (prin1-to-string query) + args)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; Code to allow visualization of RDF graphs and WQL queries using GraphViz. +;;; + +(defun make-rdf-query-dot (root query stream) + (let ((n (node root)) + (links (make-hash-table :test #'eq)) + (terminal-nodes nil)) + (flet ((node= (x y) + (eq (if (typep x 'inverse-slot) + (inverse-slot-node x) + x) + (if (typep y 'inverse-slot) + (inverse-slot-node x) + y)))) + (instrumented-walk-using-fsa n (make-path-fsa query) + #'(lambda (node terminalp transitions) + (when terminalp + (pushnew node terminal-nodes)) + (dolist (tr transitions) + (dolist (value (db-get-slot-values *db* node + (pt-input tr))) + (pushnew (cons value (pt-input tr)) + (gethash node links) + :test #'(lambda (x y) + (and (eq (car x) (car y)) + (node= (cdr x) (cdr y))))))) + nil) + *db*) + (format stream "digraph G {~%") + (maphash #'(lambda (node links) + (dolist (link links) + (destructuring-bind (child . prop) link + (etypecase prop + (inverse-slot + (format stream " ~S -> ~S [label=~S];~%" + (find-short-name *nodes* (node-uri node)) + (find-short-name *nodes* (node-uri child)) + (find-short-name *nodes* (node-uri (inverse-slot-node prop))))) + (node + (format stream " ~S -> ~S [label=~S];~%" + (find-short-name *nodes* (node-uri node)) + (find-short-name *nodes* (node-uri child)) + (find-short-name *nodes* (node-uri prop)))))))) + links) + (dolist (node terminal-nodes) + (format stream " ~S [peripheries=2];~%" (find-short-name *nodes* (node-uri node)))) + (format stream "}~%")))) + +(defun instrumented-walk-using-fsa (root fsa action db) + (let* ((*walk-states/temporary* *walk-states/temporary*) + (states (clrhash (or (pop *walk-states/temporary*) + (make-hash-table :test #'eq))))) + (labels ((w (f i) + (unless (member i (gethash f states) :test #'=) + (push i (gethash f states)) + (let ((transitions (svref fsa i))) + (or (funcall action f (first transitions) (rest transitions)) + (when (typep f 'node) + (dolist (link (rest transitions)) + (dolist (v (db-get-slot-values db f (pt-input link))) + (let ((values (w v (pt-index link)))) + (when values + (return-from instrumented-walk-using-fsa + values))))))))))) + (declare (dynamic-extent #'w)) + (when fsa + (w root 0))))) + +(defun make-dot (db output-file) + (with-open-file-output (stream output-file) + (make-dot-into-stream db stream))) + +(defun make-dot-into-stream (db stream) + (let ((nodes (make-hash-table :test 'eq))) + (flet ((normalize (node) + (cond ((typep node 'literal) + (let ((sym (gentemp))) + (setf (gethash sym nodes) (literal-string node)) + sym)) + ((null (node-uri node)) + (let ((sym (gentemp))) + (setf (gethash sym nodes) node) + sym)) + (t + (find-short-name *nodes* (node-uri node)))))) + (format stream "digraph G {~%") + (dolist (tr (db-triples db)) + (let ((s (normalize (triple-subject tr))) + (p (normalize (triple-predicate tr))) + (o (normalize (triple-object tr)))) + (format stream "~S -> ~S [label=~S];~%" s o p))) + (maphash #'(lambda (node label) + (cond ((stringp label) + (format stream "~S [shape=plaintext, label=\"\\\"~A\\\"\"];~%" + node label)) + ((null label) + (unless label + (format stream "~S [label=\"\"];~%" + node))))) + nodes) + (format stream "}~%")))) + +(defun fsa->dot (fsa stream) + (format stream "digraph G {~%") + (dotimes (i (length fsa)) + (destructuring-bind (terminalp &rest transitions) (elt fsa i) + (dolist (tr transitions) + (format stream " ~S -> ~S [label=~S];~%" + i (pt-index tr) + (find-short-name *nodes* (node-uri (pt-input tr))))) + (when terminalp + (format stream " ~S [peripheries=2];~%" i)))) + (format stream "}~%")) diff --git a/src/goodies/serializer.lisp b/src/goodies/serializer.lisp new file mode 100644 index 0000000..8b320f0 --- /dev/null +++ b/src/goodies/serializer.lisp @@ -0,0 +1,395 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; serializer.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Functionality for serializing RDF content in various formats. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; FUNCTIONS AND MACROS FOR MARKUP GENERATION +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defun strip-attributes (tag) + (let ((i (position #\Space tag :test #'char=))) + (if i (subseq tag 0 i) tag))) + + (defmacro with-open-file-output ((stream pathname) &body body) + `(with-open-file (,stream ,pathname + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + ,@body))) + +(defmacro with-tags ((stream &rest tags) &body body) + (with-temps (s) + (if (every #'stringp tags) + (let ((open (format nil "~{<~A>~}~%" tags)) + (close (format nil "~{~}~%" + (nreverse (mapcar #'strip-attributes tags))))) + `(let ((,s ,stream)) + (princ ,open ,s) + (multiple-value-prog1 (progn ,@body) + (princ ,close ,s)))) + (with-temps (e) + `(let ((,s ,stream) + (,e (list ,@tags))) + (format ,s "~{<~A>~}~%" ,e) + (multiple-value-prog1 (progn ,@body) + (format ,s "~{~}~%" (nreverse (mapcar #'strip-attributes ,e))))))))) + +(defmacro format-with-tags ((stream &rest tags) control &rest args) + (with-temps (s) + `(let ((,s ,stream)) + (with-tags (,s ,@tags) + (format ,s ,control ,@args))))) + +(defmacro princ-with-tags ((stream &rest tags) form) + (with-temps (s) + `(let ((,s ,stream)) + (with-tags (,s ,@tags) + (princ ,form ,s))))) + +(defun comma-separated (items stream &optional (mapper nil) (only-non-null-p t)) + (let ((items (if only-non-null-p (remove nil items) items))) + (format stream "~{~A~^, ~}" (if mapper (mapcar mapper items) items)))) + +(defun xml-preamble (stream) + (format stream "~%")) + +(defun xhtml-preamble (stream) + (xml-preamble stream) + (format stream "~%")) + +(defmacro with-rdf-page ((stream prefixes) &body body) + (with-temps (s ps p) + `(let ((,s ,stream) + (,ps ,prefixes)) + (xml-preamble ,s) + (format ,s "~%" + ,p (string-dict-get (dictionary-namespaces *nodes*) ,p))) + (format ,s "]>~%") + (with-tags (,s (format nil "rdf:RDF~{ xmlns:~A=\"&~:*~A;\"~}" ,ps)) + ,@body)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; DB DUMP MECHANISM +;;; + +(defmethod db-dump ((db db) (where string) what style &optional namespaces) + (db-dump db (pathname where) what style namespaces)) + +(defmethod db-dump ((db db) (where pathname) what style &optional namespaces) + (with-open-file-output (stream where) + (db-dump db stream what style namespaces))) + +(defmethod db-dump ((db db) (where (eql t)) what style &optional namespaces) + (db-dump db *standard-output* what style namespaces)) + +(defmethod db-dump ((db db) (where stream) (what db) style &optional namespaces) + (db-dump db where (db-triples db) style namespaces)) + +(defmethod db-dump ((db db) (where stream) (thing node) style &optional namespaces) + (db-dump db where (db-find-cbd db thing) style namespaces)) + +(defmethod db-dump ((db db) (where stream) (thing list) (style (eql :ntriples)) + &optional namespaces) + (declare (ignore namespaces)) + (dump-as-ntriples thing where)) + +(defmethod db-dump ((db db) (where stream) (thing list) (style (eql :rdf/xml)) + &optional namespaces) + (dump-as-rdf/xml thing where namespaces)) + +(defmethod db-dump ((db db) (where stream) (thing list) style &optional namespaces) + (declare (ignore namespaces)) + (error "Don't know how to dump in format ~S" style)) + +(defun single-subject-triples (subject &rest predicates&objects) + (declare (dynamic-extent predicates&objects)) + (loop for predicate in predicates&objects by #'cddr + for object in (cdr predicates&objects) by #'cddr + collect (db-make-triple *db* subject predicate object))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; NTRIPLES DUMP +;;; + +(defun dump-as-ntriples (triples stream) + (let ((bnodes (make-hash-table :test #'eq)) + (index 0)) + (flet ((dump-element (element) + (cond ((typep element 'literal) + (print-literal-for-ntriples element stream) + (princ #\Space stream)) + ((node-uri element) + (format stream "<~A> " (node-uri element))) + (t + (format stream "~A " + (or (gethash element bnodes) + (setf (gethash element bnodes) + (format nil "_:A~S" (incf index))))))))) + (dolist (triple triples) + (dump-element (triple-subject triple)) + (dump-element (triple-predicate triple)) + (dump-element (triple-object triple)) + (format stream ".~%"))))) + +(defun escape-ntriples-char (char) + (cdr (assoc char '((#\\ . "\\\\") + (#\" . "\\\"") + (#\Linefeed . "\\n") + (#\Return . "\\r") + (#\Tab . "\\t")) + :test #'char=))) + +(defun escape-ntriples-string (string) + (escape-string string #'escape-ntriples-char)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF/XML DUMP +;;; + +(defun dump-as-rdf/xml (triples stream namespaces) + (let ((subjects (wilbur-make-hash-table :test #'eq)) + (bnode-objects (wilbur-make-hash-table :test #'eq)) + (subjects-done (wilbur-make-hash-table :test #'eq)) + (namespaces (or namespaces (namespaces)))) + (labels ((qname (node use-entities-p) + (find-short-name *nodes* (node-uri node) use-entities-p)) + (dump (frame properties &optional (level 0)) + (unless (and (zerop level) + (wilbur-gethash frame subjects-done) + (wilbur-gethash frame bnode-objects)) + (with-tags (stream (format nil "rdf:Description~@[ rdf:about=\"~A\"~]" + (qname frame t))) + (dolist+ ((predicate . object) properties) + (let ((tag (qname predicate nil))) + (cond ((typep object 'literal) + (with-tags (stream tag) + (princ (escape-xml-string (literal-string object)) + stream))) + ((node-uri object) + (format stream "<~A rdf:resource=\"~A\"/>~%" + tag (qname object t))) + ((wilbur-gethash object bnode-objects) + (with-tags (stream tag) + (dump object (wilbur-gethash object subjects) (1+ level)) + (setf (wilbur-gethash object subjects-done) object))) + (t + (error "Cannot serialize"))))))))) + (declare (dynamic-extent #'qname #'dump)) + (with-rdf-page (stream namespaces) + (dolist (triple triples) + (let ((subject (triple-subject triple)) + (object (triple-object triple))) + (push (cons (triple-predicate triple) object) + (wilbur-gethash subject subjects)) + (unless (or (typep object 'literal) + (node-uri object) + (wilbur-gethash object bnode-objects)) + (setf (wilbur-gethash object bnode-objects) object)))) + (maphash #'dump subjects))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CHARACTER & STRING ESCAPING +;;; + +(defun escape-xml-char (char) + (cdr (assoc char '((#\< . "<") + (#\> . ">") + (#\& . "&") + (#\' . "'") + (#\" . """)) + :test #'char=))) + +(defun escape-xml-string (string &optional (extended-chars-p #+:sbcl t #-:sbcl nil)) + (components->string (mapcar #'(lambda (c) + (if (< c 128) + (or (escape-xml-char (code-char c)) + (code-char c)) + (format nil "&#x~X;" c))) + (if extended-chars-p + (extended-string->char-codes string) + (utf8-string->char-codes string))))) + +(defun escape-json-string (string &optional (extended-chars-p #+:sbcl t #-:sbcl nil)) + (components->string (mapcar #'(lambda (c) + (cond ((= c 34) "\\\"") ; double-quote + ((> c 127) (format nil "\\u~4,'0X" c)) + (t (code-char c)))) + (if extended-chars-p + (extended-string->char-codes string) + (utf8-string->char-codes string))))) + +(defun escape-string (string char-escape-function) + ;; This tries to be clever about stuff that does not need to be escaped + (labels ((escape (s n i parts) + (let ((j (position-if char-escape-function s :start i))) + (cond (j (escape s n (1+ j) + (list* (funcall char-escape-function (char s j)) + (subseq s i j) + parts))) + (parts (components->string (nreverse (cons (subseq s i) parts)))) + (t s))))) + (escape string (length string) 0 nil))) + +#-:allegro +(defun 8bit-char-string->octets (string) + (let ((octets nil)) + (map nil + #'(lambda (char) + (let ((c (char-code char))) + (cond ((< c 128) + (push c octets)) + (t + (push (logior (ash c -6) #b11000000) octets) + (push (logior (logand c #b00111111) #b10000000) octets))))) + string) + (nreverse (cons 0 octets)))) + +#-:allegro +(defun utf8-string->octets (string) + (mapcar #'char-code (coerce string 'list))) + +(defun extended-string->char-codes (string) + (mapcar #'char-code (coerce string 'list))) + +(defun utf8-string->char-codes (string) + (labels ((utf8 (octets codes) + (dsb (&optional octet &rest octets) octets + (cond ((or (null octet) (zerop octet)) + (nreverse codes)) + ((= (logand octet #b10000000) 0) + (utf8 octets (cons octet codes))) + ((= (logand octet #b11100000) #b11000000) + (dsb (octet2 &rest octets) octets + (utf8 octets + (cons (logior (ash (logand octet #b00011111) 6) + (logand octet2 #b00111111)) + codes)))) + ((= (logand octet #b11110000) #b11100000) + (dsb (octet2 octet3 &rest octets) octets + (utf8 octets + (cons (logior (ash (logand octet #b00011111) 12) + (ash (logand octet2 #b00111111) 6) + (logand octet3 #b00111111)) + codes)))) + ((= (logand octet #b11111000) #b11110000) + (dsb (octet2 octet3 octet4 &rest octets) octets + (utf8 octets + (cons (logior (ash (logand octet #b00011111) 18) + (ash (logand octet2 #b00111111) 12) + (ash (logand octet3 #b00111111) 6) + (logand octet4 #b00111111)) + codes)))) + (t + ;; This could be a hack, and I am not sure if it is correct + (utf8 (list* (logior (ash octet -6) #b11000000) + (logior (logand octet #b00111111) #b10000000) + octets) + codes)))))) + (and string + (utf8 #+:allegro (coerce (excl:string-to-octets string) 'list) + #-:allegro (utf8-string->octets string) + nil)))) + +(defun utf8-string->extended-string (string) + (coerce (mapcar #'code-char (utf8-string->char-codes string)) 'string)) + +(defun components->string (components) + (with-output-to-string (stream) + (dolist (component components) + (princ component stream)))) diff --git a/src/nox/core-constants.lisp b/src/nox/core-constants.lisp new file mode 100644 index 0000000..055d97a --- /dev/null +++ b/src/nox/core-constants.lisp @@ -0,0 +1,285 @@ +;;; -*- package: NOX; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; core-constants.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains definitions for various constants used by the +;;; RDF parser (mostly URIs). Given that the XML parser has to deal with the +;;; issue of RDF M+S vagueness on the namespaces of RDF attributes (such as +;;; "about"), the definitions in this file are in the NOX package. +;;; +;;; Generally, I hate this stuff since I never seem to get the constant +;;; definitions right vis-a-vis compile time vs. load-time. :-( +;;; + + +(in-package "NOX") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HELPERS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -rdf-uri- #."http://www.w3.org/1999/02/22-rdf-syntax-ns#") + (defconstant -rdfs-uri- #."http://www.w3.org/2000/01/rdf-schema#") + (defconstant -xsd-uri- #."http://www.w3.org/2001/XMLSchema#") + (defconstant -owl-uri- #."http://www.w3.org/2002/07/owl#") + (defconstant -daml-uri- #."http://www.daml.org/2000/12/daml+oil#") + + (defmacro rdf-uri (string) `(concatenate 'string -rdf-uri- ,string)) + (defmacro rdfs-uri (string) `(concatenate 'string -rdfs-uri- ,string)) + (defmacro xsd-uri (string) `(concatenate 'string -xsd-uri- ,string)) + (defmacro owl-uri (string) `(concatenate 'string -owl-uri- ,string)) + (defmacro daml-uri (string) `(concatenate 'string -daml-uri- ,string)) + + (defconstant -alternate-rdf-uri- + #."http://www.w3.org/TR/REC-rdf-syntax/") + (defconstant -alternate-rdfs-uri- + #."http://www.w3.org/TR/1999/PR-rdf-schema-19990303#")) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF M+S ATTRIBUTE URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -rdf-id-uri- #.(rdf-uri "ID")) + (defconstant -rdf-resource-uri- #.(rdf-uri "resource")) + (defconstant -rdf-about-uri- #.(rdf-uri "about")) + (defconstant -rdf-abouteach-uri- #.(rdf-uri "aboutEach")) + (defconstant -rdf-abouteachprefix-uri- #.(rdf-uri "aboutEachPrefix")) + (defconstant -rdf-bagid-uri- #.(rdf-uri "bagID")) + (defconstant -rdf-parsetype-uri- #.(rdf-uri "parseType")) + (defconstant -rdf-datatype-uri- #.(rdf-uri "datatype")) + (defconstant -rdf-nodeid-uri- #.(rdf-uri "nodeID")) + (defconstant -xml-lang-attr- "xml:lang")) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF M+S RESOURCE, PROPERTY, ETC. URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -rdf-description-uri- #.(rdf-uri "Description")) + (defconstant -rdf-type-uri- #.(rdf-uri "type")) + (defconstant -rdf-rdf-uri- #.(rdf-uri "RDF")) + (defconstant -rdf-li-uri- #.(rdf-uri "li")) + (defconstant -rdf-statement-uri- #.(rdf-uri "Statement")) + (defconstant -rdf-subject-uri- #.(rdf-uri "subject")) + (defconstant -rdf-predicate-uri- #.(rdf-uri "predicate")) + (defconstant -rdf-object-uri- #.(rdf-uri "object")) + (defconstant -rdf-xmlliteral-uri- #.(rdf-uri "XMLLiteral")) + (defconstant -rdf-bag-uri- #.(rdf-uri "Bag")) + (defconstant -rdf-seq-uri- #.(rdf-uri "Seq")) + (defconstant -rdf-alt-uri- #.(rdf-uri "Alt")) + (defconstant -rdf-list-uri- #.(rdf-uri "List")) + (defconstant -rdf-first-uri- #.(rdf-uri "first")) + (defconstant -rdf-rest-uri- #.(rdf-uri "rest")) + (defconstant -rdf-nil-uri- #.(rdf-uri "nil"))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF SCHEMA URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -rdfs-resource-uri- #.(rdfs-uri "Resource")) + (defconstant -rdfs-class-uri- #.(rdfs-uri "Class")) + (defconstant -rdfs-subclassof-uri- #.(rdfs-uri "subClassOf")) + (defconstant -rdfs-subpropertyof-uri- #.(rdfs-uri "subPropertyOf")) + (defconstant -rdfs-seealso-uri- #.(rdfs-uri "seeAlso")) + (defconstant -rdfs-isdefinedby-uri- #.(rdfs-uri "isDefinedBy")) + (defconstant -rdfs-constraintresource-uri- #.(rdfs-uri "ConstraintResource")) + (defconstant -rdfs-constraintproperty-uri- #.(rdfs-uri "ConstraintProperty")) + (defconstant -rdfs-range-uri- #.(rdfs-uri "range")) + (defconstant -rdfs-domain-uri- #.(rdfs-uri "domain")) + (defconstant -rdfs-comment-uri- #.(rdfs-uri "comment")) + (defconstant -rdfs-label-uri- #.(rdfs-uri "label")) + (defconstant -rdfs-literal-uri- #.(rdfs-uri "Literal")) + (defconstant -rdfs-datatype-uri- #.(rdfs-uri "Datatype")) + (defconstant -rdfs-container-uri- #.(rdfs-uri "Container ")) + (defconstant -rdfs-member-uri- #.(rdfs-uri "member"))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; XSD URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -xsd-string-uri- #.(xsd-uri "string")) + (defconstant -xsd-boolean-uri- #.(xsd-uri "boolean")) + ;;(defconstant -xsd-decimal-uri- #.(xsd-uri "decimal")) + (defconstant -xsd-float-uri- #.(xsd-uri "float")) + (defconstant -xsd-double-uri- #.(xsd-uri "double")) + (defconstant -xsd-datetime-uri- #.(xsd-uri "dateTime")) + ;;(defconstant -xsd-time-uri- #.(xsd-uri "time")) + (defconstant -xsd-date-uri- #.(xsd-uri "date")) + ;;(defconstant -xsd-gyearmonth-uri- #.(xsd-uri "gYearMonth")) + ;;(defconstant -xsd-gyear-uri- #.(xsd-uri "gYear")) + ;;(defconstant -xsd-gmonthday-uri- #.(xsd-uri "gMonthDay")) + ;;(defconstant -xsd-gday-uri- #.(xsd-uri "gDay")) + ;;(defconstant -xsd-gmonth-uri- #.(xsd-uri "gMonth")) + ;;(defconstant -xsd-hexbinary-uri- #.(xsd-uri "hexBinary")) + ;;(defconstant -xsd-base64binary-uri- #.(xsd-uri "base64Binary")) + ;;(defconstant -xsd-anyuri-uri- #.(xsd-uri "anyURI")) + (defconstant -xsd-normalizedstring-uri- #.(xsd-uri "normalizedString")) + ;;(defconstant -xsd-token-uri- #.(xsd-uri "token")) + ;;(defconstant -xsd-language-uri- #.(xsd-uri "language")) + ;;(defconstant -xsd-nmtoken-uri- #.(xsd-uri "NMTOKEN")) + ;;(defconstant -xsd-name-uri- #.(xsd-uri "Name")) + ;;(defconstant -xsd-ncname-uri- #.(xsd-uri "NCName")) + (defconstant -xsd-integer-uri- #.(xsd-uri "integer")) + ;;(defconstant -xsd-nonpositiveinteger-uri- #.(xsd-uri "nonPositiveInteger")) + ;;(defconstant -xsd-negativeinteger-uri- #.(xsd-uri "negativeInteger")) + ;;(defconstant -xsd-long-uri- #.(xsd-uri "long")) + (defconstant -xsd-int-uri- #.(xsd-uri "int")) + ;;(defconstant -xsd-short-uri- #.(xsd-uri "short")) + ;;(defconstant -xsd-byte-uri- #.(xsd-uri "byte")) + ;;(defconstant -xsd-nonnegativeinteger-uri- #.(xsd-uri "nonNegativeInteger")) + ;;(defconstant -xsd-unsignedlong-uri- #.(xsd-uri "unsignedLong")) + ;;(defconstant -xsd-unsignedint-uri- #.(xsd-uri "unsignedInt")) + ;;(defconstant -xsd-unsignedshort-uri- #.(xsd-uri "unsignedShort")) + ;;(defconstant -xsd-unsignedbyte-uri- #.(xsd-uri "unsignedByte")) + ;;(defconstant -xsd-positiveinteger-uri- #.(xsd-uri "positiveInteger")) + ) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RDF ATTRIBUTE LISTS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -rdf-attrs- '#.`(,-rdf-id-uri- + ,-rdf-resource-uri- + ,-rdf-about-uri- + ,-rdf-abouteach-uri- + ,-rdf-abouteachprefix-uri- + ,-rdf-bagid-uri- + ,-rdf-parsetype-uri- + ,-rdf-datatype-uri- + ,-rdf-nodeid-uri- + ,-xml-lang-attr-)) + + (defconstant -rdf-attr-map- #.`'((,"ID" . ,-rdf-id-uri-) + (,"resource" . ,-rdf-resource-uri-) + (,"about" . ,-rdf-about-uri-) + (,"aboutEach" . ,-rdf-abouteach-uri-) + (,"aboutEachPrefix" . ,-rdf-abouteachprefix-uri-) + (,"bagID" . ,-rdf-bagid-uri-) + (,"parseType" . ,-rdf-parsetype-uri-) + (,"datatype" . ,-rdf-datatype-uri-) + (,"nodeID" . ,-rdf-nodeid-uri-)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; OWL URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -owl-list-uri- #.(owl-uri "List")) + (defconstant -owl-first-uri- #.(owl-uri "first")) + (defconstant -owl-rest-uri- #.(owl-uri "rest")) + (defconstant -owl-nil-uri- #.(owl-uri "nil")) + (defconstant -owl-imports-uri- #.(owl-uri "imports"))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; DAML+OIL URIS +;;; + +(eval-when (:compile-toplevel :load-toplevel) + + (defconstant -daml-list-uri- #.(daml-uri "List")) + (defconstant -daml-first-uri- #.(daml-uri "first")) + (defconstant -daml-rest-uri- #.(daml-uri "rest")) + (defconstant -daml-nil-uri- #.(daml-uri "nil"))) diff --git a/src/nox/nox-package.lisp b/src/nox/nox-package.lisp new file mode 100644 index 0000000..afdfdee --- /dev/null +++ b/src/nox/nox-package.lisp @@ -0,0 +1,221 @@ +;;; -*- package: CL-USER; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; nox-package.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Definition for the package NOX +;;; + + +(in-package "CL-USER") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; PACKAGE NOX +;;; + +(defpackage "NOX" + (:nicknames "NOKIA-XML-CL" + "WILBUR-XML") + (:use "COMMON-LISP" + #+:mcl "CCL" + #+:excl "EXCL" + #+:sbcl "SB-SYS") + (:export "XML-ERROR" ; from xml-util.lisp + "ERROR-THING" + "SYNTAX-ERROR" + "PI-TERMINATION-PROBLEM" + "DTD-TERMINATION-PROBLEM" + "UNEXPECTED-END-TAG" + "ERROR-EXPECTATION" + "UNKNOWN-DECLARATION" + "UNKNOWN-CHARACTER-REFERENCE" + "MALFORMED-URL" + "FEATURE-NOT-SUPPORTED" + "MISSING-DEFINITION" + "ERROR-DEFINITION-TYPE" + "MISSING-ENTITY-DEFINITION" + "MISSING-NAMESPACE-DEFINITION" + "XML-WARNING" + "*CURRENT-PARSER*" + "READ-USING" + "STRING-DICT-GET" + "STRING-DICT-GET-BY-VALUE" + "STRING-DICT-ADD" + "STRING-DICT-DEL" + "DO-STRING-DICT" + "MAKE-FILE-URL" + "MAKE-HTTP-URL" + "PARSE-URL" + "TOKEN" + "TOKEN-STRING" + "OPEN-TAG" + "CLOSE-TAG" + "ENTITY-DECLARATION" + "ENTITY-NAME" + "COMMENT" + "CHAR-CONTENT" + "TAG-COUNTERPART" + "TAG-ATTRIBUTE" + "TAG-ATTRIBUTES" + "TAG-EMPTY-P" + "TAG-NAMESPACES" + "START-ELEMENT" + "END-ELEMENT" + "CHAR-CONTENT" + "PROC-INSTRUCTION" + "START-DOCUMENT" + "END-DOCUMENT" + "MAYBE-USE-NAMESPACE" + "SAX-CONSUMER" + "SAX-CONSUMER-PRODUCER" + "SAX-CONSUMER-MODE" + "SAX-PRODUCER" + "SAX-PRODUCER-CONSUMER" + "SAX-FILTER" + "FIND-FIRST-PRODUCER" + "-WHITESPACE-CHARS-" + "WITH-RESOURCE-FROM-POOL" + "DEFINE-RESOURCE-POOL" + "COLLAPSE-WHITESPACE" + "*NAME-READER*" ; from xml-parser.lisp + "XML-PARSER" + "GET-ENTITY" + "GET-CANONICAL-URI" + "PARSE" + "EXPAND-NAME-WITH-NAMESPACE" + "PARSE-FROM-STREAM" + "PARSE-FROM-FILE" + "XML-FORMATTER" + "REPLAY" + "REVERSE-EXPAND-NAME" + "TREE-PARSER" + "STRING->KEYWORD" + "PARSER-INTERPRET-CONTENT" + "-RDF-URI-" ; from rdf-constants.lisp + "-RDFS-URI-" + "-XSD-URI-" + "RDF-URI" + "RDFS-URI" + "XSD-URI" + "OWL-URI" + "-RDF-ATTRS-" + "-RDF-ATTR-MAP-" + "-RDF-ID-URI-" + "-RDF-RESOURCE-URI-" + "-RDF-ABOUT-URI-" + "-RDF-ABOUTEACH-URI-" + "-RDF-ABOUTEACHPREFIX-URI-" + "-RDF-BAGID-URI-" + "-RDF-PARSETYPE-URI-" + "-RDF-DATATYPE-URI-" + "-RDF-NODEID-URI-" + "-XML-LANG-ATTR-" + "-RDF-DESCRIPTION-URI-" + "-RDF-TYPE-URI-" + "-RDF-RDF-URI-" + "-RDF-LI-URI-" + "-RDF-STATEMENT-URI-" + "-RDF-SUBJECT-URI-" + "-RDF-PREDICATE-URI-" + "-RDF-OBJECT-URI-" + "-RDF-BAG-URI-" + "-RDF-SEQ-URI-" + "-RDF-ALT-URI-" + "-RDF-FIRST-URI-" + "-RDF-REST-URI-" + "-RDF-NIL-URI-" + "-RDFS-RESOURCE-URI-" + "-RDFS-CLASS-URI-" + "-RDFS-SUBCLASSOF-URI-" + "-RDFS-SUBPROPERTYOF-URI-" + "-RDFS-SEEALSO-URI-" + "-RDFS-ISDEFINEDBY-URI-" + "-RDFS-CONSTRAINTRESOURCE-URI-" + "-RDFS-CONSTRAINTPROPERTY-URI-" + "-RDFS-RANGE-URI-" + "-RDFS-DOMAIN-URI-" + "-RDFS-COMMENT-URI-" + "-RDFS-LABEL-URI-" + "-RDFS-LITERAL-URI-" + "-RDFS-CONTAINER-URI-" + "-OWL-LIST-URI-" + "-OWL-FIRST-URI-" + "-OWL-REST-URI-" + "-OWL-NIL-URI-" + "-OWL-IMPORTS-URI-")) diff --git a/src/nox/xml-parser.lisp b/src/nox/xml-parser.lisp new file mode 100644 index 0000000..83714f8 --- /dev/null +++ b/src/nox/xml-parser.lisp @@ -0,0 +1,631 @@ +;;; -*- package: NOX; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; xml-parser.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains an implementation of an XML parser. This +;;; parser was motivated by RDF, and consequently does not implement all the +;;; features of XML 1.0. In fact, it needs a lot of work. Tough... +;;; + + +(in-package "NOX") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; NAME READTABLE +;;; + +(eval-when (:compile-toplevel :load-toplevel) + (defconstant -name-start-characters- + (let ((s (concatenate 'string + (loop for i from (char-code #\a) to (char-code #\z) + collect (code-char i))))) + (concatenate 'string s (string-upcase s) "_:"))) + (defconstant -name-characters- + (let ((v (make-array 256))) + (dotimes (i 256) + (setf (svref v i) nil)) + (dolist (c (concatenate 'list -name-start-characters- + (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\. #\-))) + (setf (svref v (char-code c)) t)) + v))) + +(defvar *nr-buffer* (make-base-string 256 :adjustable t :fill-pointer 0)) + +(defun name-reader (stream char) + (setf (fill-pointer *nr-buffer*) 0) + (vector-push char *nr-buffer*) + (with-loop&read-char (c stream nil) + (cond ((and c (svref -name-characters- (char-code c))) + (vector-push-extend c *nr-buffer*)) + (t + (when c (unread-char c stream)) + (return (concatenate 'string *nr-buffer*)))))) + +(defun single-character-reader (stream char) + (declare (ignore stream)) + char) + +(defun not-allowed-reader (stream char) + (declare (ignore stream)) + (error 'syntax-error :thing char)) + +(define-readtable *name-reader* nil + (dotimes (i 256) + (let ((c (code-char i))) + (unless (whitespace-char-p c) + (set-macro-character c #'not-allowed-reader)))) + (set-macro-character #\/ #'single-character-reader) + (set-macro-character #\! #'name-reader) + (set-macro-character #\? #'name-reader) + (map nil #'(lambda (c) + (set-macro-character c #'name-reader)) + -name-start-characters-)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; XML READTABLE +;;; + +(defun read-declaration (stream name) + (declare (special *dtd-reader*)) ; forward ref + (cond ((string= name "!DOCTYPE") + (let ((name (read-using *name-reader* stream t)) + (next (skip-whitespace stream))) + (cond ((not (eql next #\[)) + (make-instance 'dtd-start + :string name :externalp t + :stuff (read-delimited-list #\> stream t))) + (t + (setf (parser-in-dtd-p *current-parser*) t + (parser-readtable *current-parser*) *dtd-reader*) + (skip-whitespace stream t) ; skip [ + (make-instance 'dtd-start :string name))))) + ((string= name "!") + (let ((char (read-char stream t nil t))) + (cond ((char= char #\[) ; CDATA, INCLUDE, IGNORE + (let ((name (read-until-char stream #\[))) + (cond ((string= name "CDATA") + (read-until-%%> stream #\])) + ((find name '("INCLUDE" "IGNORE") :test #'string=) + (error 'xml-feature-not-supported :thing name)) + (t + (error 'syntax-error :thing "![")))))))) + ((string= name "!--" :end1 3) + (make-instance 'comment :string (read-until-%%> stream #\-))) + (t + (error 'unknown-declaration :thing name)))) + +(defun open-anglebracket-reader (stream char) + (declare (ignore char)) + (let ((name (read-using *name-reader* stream t))) + (cond ((eql name #\/) + (make-instance 'close-tag + :string (first (read-delimited-list #\> stream t)))) + ((char= (char name 0) #\!) + (read-declaration stream name)) + ((char= (char name 0) #\?) + (let* ((stuff (read-delimited-list #\> stream t))) + (if (eql (first (last stuff)) #\?) + (make-instance 'proc-instruction :string name) ; ignore attrs + (error 'pi-termination-problem :thing name)))) + (t + (let* ((stuff (read-delimited-list #\> stream t)) + (parent (first (parser-path *current-parser*))) + (tag (make-instance 'open-tag + :string name + :base (if parent + (tag-base parent) + (parser-locator *current-parser*)))) + (attr nil)) + (loop (cond ((null stuff) + (return tag)) + ((eql (setf attr (pop stuff)) #\/) + (setf (tag-empty-p tag) t) + (return tag)) + ((eql (pop stuff) #\=) + (setf (tag-attribute tag attr) (pop stuff))) + (t + (error 'syntax-error :thing "missing ="))))))))) + +(defun quoted-string-reader (stream char) + (read-until-char-expanding-entities stream char nil)) + +(defun read-xml-token (stream &aux (char (peek-char t stream nil nil))) + (when char + (if (or (char= char #\<) + (and (char= char #\]) + (parser-in-dtd-p *current-parser*))) + (read-using (parser-readtable *current-parser*) stream) + (read-until-char-expanding-entities stream #\< t)))) + +(define-readtable *xml-reader* nil + (dotimes (i 256) + (let ((c (code-char i))) + (unless (whitespace-char-p c) + (set-macro-character c #'not-allowed-reader)))) + (set-macro-character #\< #'open-anglebracket-reader) + (set-macro-character #\> (get-macro-character #\))) + (set-macro-character #\= #'single-character-reader) + (set-macro-character #\/ #'single-character-reader) + (set-macro-character #\? #'single-character-reader) + (set-macro-character #\' #'quoted-string-reader) + (set-macro-character #\" #'quoted-string-reader) + (map nil #'(lambda (c) + (set-macro-character c #'name-reader)) + -name-start-characters-)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; DTD READTABLE +;;; + +(defun dtd-open-anglebracket-reader (stream char) + (declare (ignore char)) + (let ((name (read-using *name-reader* stream t)) + (stuff (read-delimited-list #\> stream t))) + (cond ((string= name "!ENTITY") + (make-instance 'entity-declaration + :name (pop stuff) :string (pop stuff))) + ((string= name "!ELEMENT") + (make-instance 'element-declaration + :name (pop stuff) :contentspec (pop stuff))) + ((string= name "!ATTLIST") + (make-instance 'attlist-declaration + :name (pop stuff))) + ((string= name "!NOTATION") + (error 'xml-feature-not-supported :thing name)) + (t + (error 'unknown-declaration :thing name))))) + +(defun dtd-parenthesis-reader (stream char) + (declare (ignore char)) + (read-delimited-list #\) stream t)) + +(defun close-bracket-reader (stream char) + (declare (ignore char)) + (cond ((not (parser-in-dtd-p *current-parser*)) + (error 'syntax-error :thing "]")) + ((not (char= (skip-whitespace stream t) #\>)) + (error 'dtd-termination-problem)) + (t + (setf (parser-readtable *current-parser*) *xml-reader*) + (make-instance 'dtd-end)))) + +(define-readtable *dtd-reader* *xml-reader* + (set-macro-character #\< #'dtd-open-anglebracket-reader) + (set-macro-character #\# (get-macro-character #\A)) + (set-macro-character #\] #'close-bracket-reader) + (set-macro-character #\( #'dtd-parenthesis-reader) + (set-macro-character #\) (get-macro-character #\)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS XML-PARSER +;;; + +(defclass xml-parser (sax-producer) + ((expand-namespaces-p + :initarg :expand-namespaces-p + :initform t + :reader parser-expand-namespaces-p) + (entities + :initform (make-hash-table :test #'equal) + :reader parser-entities) + (in-dtd-p + :initform nil + :accessor parser-in-dtd-p) + (canonical-uris + :initform (make-hash-table :test #'equal) + :reader parser-canonical-uris) + (readtable + :initform nil + :accessor parser-readtable) + (path + :initform nil + :accessor parser-path) + (locator + :initform nil + :accessor parser-locator))) + +(eval-when (:compile-toplevel :load-toplevel) + (defconstant -standard-entities- '(("gt" . ">") + ("lt" . "<") + ("amp" . "&") + ("quot" . "\"") + ("apos" . "'")))) + +(defmethod initialize-instance :after ((self xml-parser) &rest args) + (declare (ignore args)) + (dolist (pair -standard-entities-) + (destructuring-bind (n . e) pair (setf (get-entity self n) e))) + (setf (get-canonical-uri self -alternate-rdf-uri-) -rdf-uri- + (get-canonical-uri self -alternate-rdfs-uri-) -rdfs-uri- + (get-canonical-uri self (subseq -rdfs-uri- 0 (1- (length -rdfs-uri-)))) + -rdfs-uri-)) + +(defun get-entity (parser name) + (gethash name (parser-entities parser))) + +(defun (setf get-entity) (definition parser name) + (setf (gethash name (parser-entities parser)) definition)) + +(defun get-canonical-uri (parser uri) + (gethash uri (parser-canonical-uris parser) uri)) + +(defun (setf get-canonical-uri) (new-uri parser uri) + (setf (gethash uri (parser-canonical-uris parser)) new-uri)) + +(defmethod parse ((self xml-parser) stream locator) + (declare (special *xml-parse-buffers*)) + (let ((*current-parser* self) + (consumer (sax-producer-consumer self))) + (with-resource-from-pool (*ruc-buffer* *xml-parse-buffers*) + (with-resource-from-pool (*ruc-ee-buffer* *xml-parse-buffers*) + (setf (parser-readtable self) *xml-reader* + (parser-locator self) locator) + (handler-bind ((end-of-file #'(lambda (c) + (declare (ignore c)) + (error 'syntax-error :thing "eof")))) + (start-document consumer locator) + (parse-start self stream nil nil) + (end-document consumer (sax-consumer-mode consumer))))))) + +(defun parse-start (parser stream end namespaces &aux continuep) + (loop (multiple-value-setq (continuep namespaces) + (parse-token parser stream (read-xml-token stream) end namespaces)) + (unless continuep + (return-from parse-start nil)))) + +(defmethod parse-token ((self xml-parser) + stream (token string) ; char-content + end namespaces) + (declare (ignore stream)) + (char-content (sax-producer-consumer self) (collapse-whitespace token) + (sax-consumer-mode (sax-producer-consumer self))) + (values end namespaces)) + +(defmethod parse-token ((self xml-parser) + stream (token open-tag) end namespaces) + (flet ((expand (name) + (or (expand-name-with-namespace name namespaces) + (progn (cerror "Do not expand" + 'missing-namespace-definition :thing name) + name)))) + (declare (dynamic-extent #'expand)) + (let ((consumer (sax-producer-consumer self))) + (when (parser-expand-namespaces-p self) + (setf namespaces (add-namespaces self token namespaces)) + (shiftf (tag-original-name token) + (token-string token) + (expand (token-string token))) + (dolist (k&v (tag-attributes token)) + (setf (car k&v) (expand (car k&v))))) + (do-string-dict (key value (tag-attributes token)) + (when (string= key "xml:base") + (setf (tag-attributes token) + (string-dict-del (tag-attributes token) key)) + (setf (tag-base token) value))) + (setf (tag-namespaces token) namespaces) + (push token (parser-path self)) + (start-element consumer token (sax-consumer-mode consumer)) + (cond ((tag-empty-p token) + (end-element consumer token (sax-consumer-mode consumer)) + (pop (parser-path self))) + (t + (parse-start self stream token namespaces))) + (values end namespaces)))) + +(defun add-namespaces (parser tag namespaces) + (do-string-dict (key value (tag-attributes tag)) + (multiple-value-bind (n p) (name&prefix key) + (cond ((string= p "xmlns") + (let ((uri (get-canonical-uri parser value))) + (setf (tag-attributes tag) + (string-dict-del (tag-attributes tag) key)) + (setf namespaces + (string-dict-add namespaces n uri)) + (maybe-use-namespace (sax-producer-consumer parser) n uri))) + ((and (null p) (string= n "xmlns")) + (setf (tag-attributes tag) + (string-dict-del (tag-attributes tag) key)) + (setf namespaces + (string-dict-add namespaces + nil (get-canonical-uri parser value))))))) + namespaces) + +(defun ends-in-hash-p (string) + (declare (type string string) + (optimize (speed 3) (space 3) (safety 0))) + (let ((c (char string (1- (length string))))) + (declare (type character c)) + (or (char= c #\#) + (char= c #\/) + (char= c #\:)))) + +(defun expand-name-with-namespace (string namespaces) + (multiple-value-bind (n p) (name&prefix string) + (or (and (null p) + (hack-rdf-attribute-name n namespaces)) + (let ((uri (string-dict-get namespaces p))) + (cond (uri + (values (concatenate 'string uri (and (not (ends-in-hash-p uri)) "#") n) + n p)) + ((or (null p) (string-equal p "xml")) + (values string nil nil)) + (t + (values nil n p))))))) + +(defun hack-rdf-attribute-name (name namespaces) + (and (car (rassoc -rdf-uri- namespaces :test #'string=)) + (cdr (assoc name -rdf-attr-map- :test #'string=)))) + +(defmethod parse-token ((self xml-parser) + stream (token close-tag) end namespaces) + (declare (ignore stream)) + (cond ((null end) + (error 'unexpected-end-tag :thing (token-string end))) + ((string= (tag-original-name end) (token-string token)) + (setf (tag-counterpart token) end + (tag-counterpart end) token) + (end-element (sax-producer-consumer self) end + (sax-consumer-mode (sax-producer-consumer self))) + (pop (parser-path self)) + (values nil namespaces)) + (t + (error 'unexpected-end-tag + :expectation (tag-original-name end) + :thing (token-string token))))) + +(defmethod parse-token ((self xml-parser) + stream (token proc-instruction) end namespaces) + (declare (ignore stream end)) + (let ((consumer (sax-producer-consumer self))) + (proc-instruction consumer token (sax-consumer-mode consumer)) + (values t namespaces))) + +(defmethod parse-token ((self xml-parser) + stream (token entity-declaration) end namespaces) + (declare (ignore stream end)) + (setf (get-entity self (entity-name token)) (token-string token)) + (values t namespaces)) + +(defmethod parse-token ((self xml-parser) + stream (token comment) end namespaces) + (declare (ignore stream end)) + (values t namespaces)) + +(defmethod parse-token ((self xml-parser) + stream (token dtd-start) end namespaces) + (declare (ignore stream end)) + (when (dtd-external-p token) + (xml-warning "External DTD ignored:~{ ~S~}" (dtd-stuff token))) + (values t namespaces)) + +(defmethod parse-token ((self xml-parser) + stream (token dtd-end) end namespaces) + (declare (ignore stream end)) + (values t namespaces)) + +(defmethod parse-token ((self xml-parser) + stream (token dtd-declaration) end namespaces) + (declare (ignore stream end)) + (xml-warning "~S ignored" (class-name (class-of token))) + (values t namespaces)) + +(defmethod parse-token ((self xml-parser) stream token end namespaces) + (declare (ignore stream end)) + (if token + (error 'syntax-error :thing token) + (values nil namespaces))) ; null token signifies eof + +(defun parse-from-stream (stream locator parser-class &rest options) + (declare (dynamic-extent options)) + (let ((parser (apply #'make-instance parser-class options))) + (handler-case (values (parse parser stream locator) parser) + (xml-error (e) + (let ((*readtable* (copy-readtable nil))) + (cerror "Keep going" e)))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS XML-FORMATTER +;;; + +(defclass xml-formatter (sax-consumer) + ((stream + :initarg :stream + :initform nil + :reader formatter-stream) + (level + :initform 0 + :accessor formatter-level) + (indent-delta + :initarg :indent-delta + :initform 2 + :reader formatter-indent-delta))) + +(defmethod replay ((formatter xml-formatter) events) + (dolist (event events) + (let ((mode (sax-consumer-mode formatter))) + (etypecase event + (open-tag + (start-element formatter event mode)) + (close-tag + (end-element formatter (tag-counterpart event) mode)) + (string + (char-content formatter event mode)))))) + +(defun reverse-expand-name (name namespaces + &optional use-entities-p + &aux (nn (length name))) + (do-string-dict (prefix uri namespaces) + (let ((un (length uri))) + (when (and (>= nn un) + (string= name uri :end1 un)) + (return-from reverse-expand-name + (values (if (= nn un) + (format nil "~@[~A~]:" prefix) + (format nil (if use-entities-p "~@[&~A;~]~A" "~@[~A:~]~A") + prefix + (let ((n (subseq name un))) + (if (char= (char n 0) #\#) + (subseq n 1) n)))) + t))))) + (values name nil)) + +(defmethod start-element ((self xml-formatter) (tag open-tag) mode) + (declare (ignore mode)) + (let ((stream (formatter-stream self))) + (format stream "~&~V@T<~A" + (formatter-level self) + (reverse-expand-name (token-string tag) (tag-namespaces tag))) + (do-string-dict (attribute value (tag-attributes tag)) + (format stream " ~A=\"~A\"" + (reverse-expand-name attribute (tag-namespaces tag)) + value)) + (princ (if (tag-empty-p tag) "/>" #\>) stream) + (incf (formatter-level self) (formatter-indent-delta self)))) + +(defmethod end-element ((self xml-formatter) tag mode) + (declare (ignore mode)) + (decf (formatter-level self) (formatter-indent-delta self)) + (unless (tag-empty-p tag) + (format (formatter-stream self) "~&~V@T" + (formatter-level self) + (reverse-expand-name (token-string tag) (tag-namespaces tag))))) + +(defmethod char-content ((self xml-formatter) char-content mode) + (declare (ignore mode)) + (princ (string-trim '(#\Space #\Tab #\Newline) char-content) + (formatter-stream self))) + +(defmethod start-document ((self xml-formatter) locator) + (declare (ignore locator)) + (format (formatter-stream self) "~&")) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS TREE-PARSER +;;; + +(defclass tree-parser (sax-consumer) + ((states + :initform nil + :accessor parser-states) + (package + :initarg :package + :initform (find-package :keyword) + :reader parser-package))) + +(defmethod initialize-instance :after ((self tree-parser) &rest args + &key producer &allow-other-keys) + (declare (ignore args)) + (if producer + (setf (sax-consumer-producer self) producer + (sax-producer-consumer producer) self) + (setf (sax-consumer-producer self) (make-instance 'xml-parser :consumer self)))) + +(defmethod parser-interpret-content ((parser tree-parser) (content string)) + content) + +(defmethod start-element ((parser tree-parser) (tag open-tag) mode) + (declare (ignore mode)) + (push (list (list (string->keyword (token-string tag) (parser-package parser)))) + (parser-states parser))) + +(defmethod end-element ((parser tree-parser) (tag open-tag) mode) + (declare (ignore mode)) + (push (reverse (first (pop (parser-states parser)))) + (car (first (parser-states parser))))) + +(defmethod char-content ((parser tree-parser) (content string) mode) + (declare (ignore mode)) + (push (parser-interpret-content parser content) + (car (first (parser-states parser))))) + +(defmethod parse ((parser tree-parser) stream locator) + (setf (parser-states parser) (list (list nil))) + (parse (find-first-producer parser) stream locator) + (caar (pop (parser-states parser)))) diff --git a/src/nox/xml-util.lisp b/src/nox/xml-util.lisp new file mode 100644 index 0000000..689a4e2 --- /dev/null +++ b/src/nox/xml-util.lisp @@ -0,0 +1,774 @@ +;;; -*- package: NOX; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; xml-util.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains useful functions and other definitions for +;;; implementing an XML parser (or some other stuff, for that matter). These +;;; are separated from the actual parser so that one could replace the actual +;;; parser with another implementation (not me, but someone else might do it). +;;; + + +(in-package "NOX") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; XML CONDITION CLASSES +;;; +;;; XML-ERROR abstract +;;; SYNTAX-ERROR concrete +;;; PI-TERMINATION-PROBLEM concrete +;;; DTD-TERMINATION-PROBLEM concrete +;;; UNEXPECTED-END-TAG concrete +;;; UNKNOWN-DECLARATION concrete +;;; UNKNOWN-CHARACTER-REFERENCE concrete +;;; MALFORMED-URL concrete +;;; XML-FEATURE-NOT-SUPPORTED concrete +;;; MISSING-DEFINITION abstract +;;; MISSING-ENTITY-DEFINITION concrete, continuable +;;; MISSING-NAMESPACE-DEFINITION concrete, continuable +;;; XML-WARNING concrete, warning +;;; + +(define-condition wilbur-error (simple-error) + ((thing + :initarg :thing + :reader error-thing)) + (:report (lambda (condition stream) + (format stream (simple-condition-format-control condition) + (error-thing condition))))) + +(define-condition xml-error (wilbur-error) + ()) + +(define-condition syntax-error (xml-error) + () + (:default-initargs + :format-control "XML -- syntax error (why: ~:[unknown~;~:*~A~])")) + +(define-condition pi-termination-problem (syntax-error) + () + (:default-initargs + :format-control "XML -- unterminated PI ~S")) + +(define-condition dtd-termination-problem (syntax-error) + () + (:default-initargs + :format-control "XML -- improperly terminated DTD")) + +(define-condition unexpected-end-tag (syntax-error) + ((expectation + :initarg :expectation + :initform nil + :reader error-expectation)) + (:report (lambda (condition stream) + (format stream "XML -- unexpected end tag ~S~@[ (looking for ~S)~]" + (error-thing condition) + (error-expectation condition))))) + +(define-condition unknown-declaration (syntax-error) + () + (:default-initargs + :format-control "XML -- unknown declaration ~S")) + +(define-condition unknown-character-reference (syntax-error) + () + (:default-initargs + :format-control "XML -- unknown character reference ~S")) + +(define-condition malformed-url (syntax-error) + () + (:default-initargs + :format-control "XML -- unparseable URL ~S")) + +(define-condition xml-feature-not-supported (xml-error) + () + (:default-initargs + :format-control "XML -- ~S is not supported")) + +(define-condition missing-definition (xml-error) + ((definition-type + :initarg :type + :reader error-definition-type)) + (:report (lambda (condition stream) + (format stream "XML -- missing ~A definition ~S" + (error-definition-type condition) + (error-thing condition))))) + +(define-condition missing-entity-definition (missing-definition) + () + (:default-initargs + :type :entity)) + +(define-condition missing-namespace-definition (missing-definition) + () + (:default-initargs + :type :namespace)) + +(define-condition xml-warning (simple-warning) + ()) + +(defmacro xml-warning (message &rest args) + `(warn 'xml-warning + :format-control "XML -- ~?" + :format-arguments (list ,message (list ,@args)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; RESOURCE POOLS +;;; + +#-:mcl +(defstruct (resource-pool (:conc-name pool-)) + data + constructor + initializer + destructor) + +#-(or :mcl :excl :sbcl :lispworks) +(defmacro without-interrupts (&body body) + (warn "No working WITHOUT-INTERRUPTS in this implementation") + `(progn ,@body)) + +#-:mcl +(defmacro atomic-push (thing place) + `(without-interrupts (push ,thing ,place))) + +#-:mcl +(defmacro atomic-pop (place) + `(without-interrupts (pop ,place))) + +(defun allocate-resource-from-pool (pool &rest args) + #+:mcl + (declare (ignore args)) + #+:mcl + (ccl::allocate-resource pool) + #-:mcl + (let ((res (or (atomic-pop (pool-data pool)) + (apply (pool-constructor pool) args))) + (init (pool-initializer pool))) + (when init + (funcall init res)) + res)) + +(defun free-resource-to-pool (pool resource) + #+:mcl + (ccl::free-resource pool resource) + #-:mcl + (let ((des (pool-destructor pool))) + (when des + (funcall des resource)) + (atomic-push resource (pool-data pool)))) + +(defmacro define-resource-pool (name constructor &optional initializer destructor) + #+:mcl + (let ((r (gentemp)) + (c (gentemp)) + (i (gentemp)) + (d (gentemp))) + `(let ((,c ,constructor) + (,i ,initializer) + (,d ,destructor)) + (ccl::defresource ,name + :constructor (let (,r) + (prog1 (setf ,r (funcall ,c)) + (funcall ,i ,r))) + :initializer ,i + :destructor ,d))) + #-:mcl + `(defparameter ,name (make-resource-pool :constructor ,constructor + :initializer ,initializer + :destructor ,destructor))) + +(defmacro with-resource-from-pool ((var pool) &body body) + #+:mcl + `(ccl::using-resource (,var ,pool) ,@body) + #-:mcl + (let ((flag (gentemp)) + (g-pool (gentemp))) + `(let* ((,g-pool ,pool) + (,flag (allocate-resource-from-pool ,g-pool)) + (,var ,flag)) + (unwind-protect (progn ,@body) + (when ,flag (free-resource-to-pool ,g-pool ,flag)))))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HELPERS +;;; + +(defun make-base-string (size &rest args) + (declare (dynamic-extent args)) + (remf args :element-type) + (apply #'make-array size :element-type #+:sbcl 'extended-char #-:sbcl 'base-char args)) + +(declaim (inline make-base-string)) + +(defvar *current-parser* nil) + +(defmacro with-loop&read-char ((char stream &optional (eof-error-p t)) &body body) + `(loop (let ((,char (read-char ,stream nil nil t))) + (cond ((or ,char (not ,eof-error-p)) + ,@body) + (t + (error 'syntax-error :thing "eof while scanning")))))) + +(defun read-using (readtable stream &optional recursivep) + (let ((old-readtable *readtable*)) + (handler-case (let ((*readtable* readtable)) + (read stream t nil recursivep)) + (syntax-error (c) + (setf *readtable* old-readtable) + (error c))))) + +(defmacro define-readtable (readtablevar copied-from &body body) + `(defparameter ,readtablevar + (let ((*readtable* (copy-readtable ,copied-from))) + ,@body + *readtable*))) + +(defmacro define-macro-character (character (&rest args) &body body) + `(set-macro-character ',character #'(lambda (,@args) ,@body))) + +(defvar *ruc-buffer* nil) +(defvar *ruc-ee-buffer* nil) + +(define-resource-pool *xml-parse-buffers* + #'(lambda () (make-base-string 2048 :adjustable t :fill-pointer 0)) + #'(lambda (vector) (setf (fill-pointer vector) 0))) + +(defvar *leave-unknown-entities-unexpanded-p* t) + +(defun read-until-char-expanding-entities (stream char save-last-p + &optional (buffer *ruc-ee-buffer*)) + (setf (fill-pointer buffer) 0) + (with-loop&read-char (c stream) + (cond ((char= c char) + (when save-last-p + (unread-char c stream)) + (return (concatenate 'string buffer))) + ((char= c #\&) + (let ((name (read-until-char stream #\;))) + (if (char= (char name 0) #\#) + (multiple-value-bind (c1 c2 c3) + (resolve-character-reference name) + (vector-push-extend c1 buffer) + (when c2 + (vector-push-extend c2 buffer) + (when c3 + (vector-push-extend c3 buffer)))) + (let ((def (get-entity *current-parser* name))) + (unless def + (unless *leave-unknown-entities-unexpanded-p* + (cerror "Do not expand" 'missing-entity-definition :thing name)) + (setf def (format nil "&~A;" name))) + (dotimes (i (length def)) + (vector-push-extend (char def i) buffer)))))) + (t + (vector-push-extend c buffer))))) + +(defun resolve-character-reference (ref) + (let ((n (ignore-errors (if (char= (char ref 1) #\x) + (parse-integer ref :start 2 :radix 16) + (parse-integer ref :start 1 :radix 10))))) + (if (and (integerp n) (< n 65536)) + (let ((b (integer-length n))) ; poor man's UTF8 enconding :-) + (cond ((<= b 7) + (code-char n)) + ((<= b 11) + (values (code-char (logior #b11000000 (ash n -6))) + (code-char (logior #b10000000 (logand n #b00111111))))) + ((<= b 16) + (values (code-char (logior #b11100000 (ash n -12))) + (code-char (logior #b10000000 (logand (ash n -6)) #b00111111)) + (code-char (logior #b10000000 (logand n #b00111111))))))) + (error 'unknown-character-reference :thing ref)))) + +(defun read-until-char (stream char &optional (buffer *ruc-buffer*)) + (setf (fill-pointer buffer) 0) + (with-loop&read-char (c stream) + (if (char= c char) + (return (concatenate 'string buffer)) + (vector-push-extend c buffer)))) + +(defun read-until-%%> (stream char &aux chars) + (with-loop&read-char (c stream) + (cond ((not (char= c char)) + (push c chars)) + ((or (not (char= (setf c (read-char stream t nil t)) char)) + (not (char= (peek-char nil stream t nil t) #\>))) + (push char chars) + (push c chars)) + (t + (read-char stream t nil t) ; skip #\> + (return (concatenate 'string (nreverse chars))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro whitespace-char-p (char) + (with-temps (c) + `(let ((,c ,char)) + ;; let's assume this works for now :-) + (or (char= ,c #\Space) + (not (graphic-char-p ,c))))))) + +(eval-when (:compile-toplevel :load-toplevel) + (defconstant -whitespace-chars- + (let ((chars nil)) + (dotimes (i 256) + (let ((c (code-char i))) + (when (whitespace-char-p c) + (push c chars)))) + (concatenate 'string chars)))) + +(defun name&prefix (string) + (let ((i (position #\: string))) + (cond ((null i) + (values string nil)) + ((zerop i) + (values (subseq string 1) nil)) + ((= i (1- (length string))) + (values nil (subseq string 0 i))) + (t + (values (subseq string (1+ i)) (subseq string 0 i)))))) + +(defun skip-whitespace (stream &optional pop-char-p) + (let ((char (peek-char t stream t nil t))) + (if pop-char-p + (read-char stream t nil t) + char))) + +(defun collapse-whitespace (string) + ;; new version with "poor man's Unicode support" :-( + (labels ((collapse (mode old new) + (if old + (dsb (c &rest old) old + (cond ((zerop (logand (char-code c) #b10000000)) + (if (whitespace-char-p c) + (collapse (if (eq mode :start) :start :white) old new) + (collapse :collect old + (if (eq mode :white) + (list* c #\Space new) + (cons c new))))) + ((= (logand (char-code c) #b11100000) 192) + (collapse :collect (cdr old) + (if (eq mode :white) + (list* (car old) c #\Space new) + (list* (car old) c new)))) + ((= (logand (char-code c) #b11110000) 224) + (collapse :collect (cddr old) + (if (eq mode :white) + (list* (cadr old) (car old) c #\Space new) + (list* (cadr old) (car old) c new)))) + (t + (error "Cannot decode this: ~S" (cons c old))))) + (concatenate 'string (nreverse new))))) + (declare (dynamic-extent #'collapse)) + (collapse :start (coerce string 'list) nil))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; URL FUNCTIONS +;;; +;;; We currently support http, file, urn, mailto and tel URL parsing. +;;; + +(defun parse-url (u &optional (errorp nil)) + (cond ((string= u "http://" :end1 7) + (flet ((url (host port &optional (path "/")) + `(:host ,host + :port ,port + :path ,(if (zerop (length path)) "/" path)))) + (let ((i (position #\: u :start 7)) + (j (position #\/ u :start 7))) + (cond ((and (null i) (null j)) + (values :http (url (subseq u 7) 80 "/"))) + ((and i (< i (or j most-positive-fixnum))) + (let ((h (subseq u 7 i))) + (multiple-value-bind (p j) + (parse-integer u + :start (1+ i) + :junk-allowed t) + (values :http (url h p (subseq u j)))))) + (t + (values :http (url (subseq u 7 j) 80 (subseq u j)))))))) + ((string= u "file://" :end1 7) + (let ((p (subseq u 7))) + (values :file + `(:path ,(translate-logical-pathname + (canonical->host-specific-path p)))))) + ((string= u "mailto:" :end1 7) + (values :mailto + `(:path ,(subseq u 7)))) + ((string= u "tel:" :end1 4) + (if (char= (char u 4) #\+) + (values :tel + `(:number ,(subseq u 5) :plusp t)) + (values :tel + `(:number ,(subseq u 4) :plusp nil)))) + ((string= u "urn:" :end1 4) + (values :urn `(:path ,(subseq u 4)))) + (errorp + (error 'malformed-url :thing u)) + (t + (let ((i (position #\: u))) + (values :unknown + `(:scheme ,(subseq u 0 i) :path ,(subseq u (1+ i)))))))) + +(defun host-specific->canonical-path (path) + #+(and :mcl (not :openmcl)) + (substitute #\/ #\: (subseq path (position #\: path))) + #+(or (not :mcl) :openmcl) ; = unix, since we do not do Windows yet (maybe never) + path) + +(defun canonical->host-specific-path (path) + #+(and :mcl (not :openmcl)) + (let ((p (namestring (translate-logical-pathname "home:")))) + (concatenate 'string (subseq p 0 (position #\: p)) (substitute #\: #\/ path))) + #+(or (not :mcl) :openmcl) ; = unix, since we do not do Windows yet (maybe never) + path) + +(defun make-file-url (pathname) + (format nil "file://~A" + (host-specific->canonical-path + (namestring (translate-logical-pathname (pathname pathname)))))) + +(defun make-http-url (host port path) + (format nil "http://~A~@[:~S~]~A" host port (or path "/"))) + +(defun make-mailto-url (address) + (format nil "mailto:~A" address)) + +(defun make-tel-url (number &optional (include-plus-p t)) + (format nil "tel:~@[+~]~A" (not include-plus-p) number)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; XML TOKEN CLASSES +;;; +;;; The lexical scanner of the parser (function read-xml-token) returns instances of +;;; XML token classes. Some of these are processed by the parser, some are ignored. +;;; +;;; TOKEN abstract +;;; TAG abstract +;;; OPEN-TAG processed +;;; CLOSE-TAG processed +;;; PROC-INSTRUCTION ignored +;;; DTD-DECLARATION abstract +;;; ENTITY-DECLARATION processed +;;; ELEMENT-DECLARATION ignored w/ warning +;;; ATTLIST-DECLARATION ignored w/ warning +;;; COMMENT ignored +;;; CHAR-CONTENT processed (this is a string, not an instance) +;;; DTD-BRACKET abstract +;;; DTD-START ignored w/ warning (if external DTD) +;;; DTD-END ignored +;;; + +(defclass token () + ((string + :initarg :string + :accessor token-string))) + +(defclass tag (token) + ((counterpart + :initform nil + :accessor tag-counterpart))) + +(defmethod print-object ((self tag) stream) + (print-unreadable-object (self stream :type t) + (princ (token-string self) stream))) + +(defclass open-tag (tag) + ((original-name + :initform nil + :accessor tag-original-name) + (attributes + :initform nil + :accessor tag-attributes) + (emptyp + :initform nil + :accessor tag-empty-p) + (namespaces + :initarg :namespaces + :accessor tag-namespaces) + (base + :initarg :base + :initform nil + :accessor tag-base))) + +(defun tag-attribute (tag attribute) ; assuming OPEN-TAG + (string-dict-get (tag-attributes tag) attribute)) + +(defun (setf tag-attribute) (value tag attribute) ; assuming OPEN-TAG + (setf (tag-attributes tag) (string-dict-add (tag-attributes tag) attribute value)) + value) + +(defclass close-tag (tag) + ()) + +(defclass proc-instruction (token) + ()) + +(defclass dtd-declaration (token) + ()) + +(defclass entity-declaration (dtd-declaration) + ((name + :initarg :name + :reader entity-name))) + +(defclass element-declaration (dtd-declaration) + ((name + :initarg :name + :reader element-name) + (contentspec + :initarg :contentspec + :reader element-contentspec))) + +(defclass attlist-declaration (dtd-declaration) + ((name + :initarg :name + :reader attlist-name) + ;; should be more + )) + +(defclass comment (dtd-declaration) + ()) + +(defclass dtd-bracket (token) + ()) + +(defclass dtd-start (dtd-bracket) + ((externalp + :initarg :externalp + :initform nil + :reader dtd-external-p) + (stuff + :initarg :stuff + :initform nil + :reader dtd-stuff))) + +(defclass dtd-end (dtd-bracket) + ()) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SAX-CONSUMER +;;; SIMPLE SAX 1 -LIKE INTERFACE ("CL-SAX") +;;; + +(defclass sax-consumer () + ((producer + :initarg :producer + :initform nil + :accessor sax-consumer-producer) + (debugp + :initarg :debugp + :initform nil + :reader sax-consumer-debug-p))) + +(defgeneric start-element (consumer tag mode)) +(defgeneric end-element (consumer tag mode)) +(defgeneric char-content (consumer char-content mode)) +(defgeneric proc-instruction (consumer instruction mode)) +(defgeneric start-document (consumer locator)) +(defgeneric end-document (consumer mode)) +(defgeneric maybe-use-namespace (consumer prefix uri)) + +(defun debug-format (consumer string &rest args) + (when (sax-consumer-debug-p consumer) + (apply #'format *debug-io* string args))) + +(defmethod find-first-producer ((consumer sax-consumer)) + (find-first-producer (sax-consumer-producer consumer))) + +(defmethod sax-consumer-mode ((self sax-consumer)) + nil) + +(defmethod start-element ((self sax-consumer) (tag open-tag) mode) + (debug-format self "~&START ~A ~S ~S ~S" + (token-string tag) (tag-attributes tag) mode (tag-base tag))) + +(defmethod end-element ((self sax-consumer) (tag open-tag) mode) + (debug-format self "~&END ~A ~S ~S" (token-string tag) mode (tag-base tag))) + +(defmethod char-content ((self sax-consumer) (char-content string) mode) + (debug-format self "~&CHARACTERS ~S ~S" char-content mode)) + +(defmethod proc-instruction ((self sax-consumer) (tag proc-instruction) mode) + (debug-format self "~&PI ~S ~S" (token-string tag) mode)) + +(defmethod start-document ((self sax-consumer) locator) + (debug-format self "~&START DOCUMENT ~S" locator)) + +(defmethod end-document ((self sax-consumer) mode) + (debug-format self "~&END DOCUMENT ~S" mode)) + +(defmethod maybe-use-namespace ((self sax-consumer) prefix uri) + (debug-format self "&NAMESPACE ~S ~S" prefix uri)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SAX-PRODUCER +;;; + +(defclass sax-producer () + ((consumer + :accessor sax-producer-consumer))) + +(defmethod find-first-producer ((producer sax-producer)) + producer) + +(defmethod initialize-instance :after ((self sax-producer) + &key (consumer + (make-instance 'sax-consumer + :debugp t)) + &allow-other-keys) + (setf (sax-producer-consumer self) consumer)) + +(defmethod (setf sax-producer-consumer) :after ((consumer sax-consumer) + (producer sax-producer)) + (setf (sax-consumer-producer consumer) producer)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS SAX-FILTER +;;; + +(defclass sax-filter (sax-consumer sax-producer) + ((blockp + :initform nil + :initarg :blockp + :accessor sax-filter-block-p))) + +(defmethod start-element ((self sax-filter) (tag open-tag) mode) + (unless (sax-filter-block-p self) + (start-element (sax-producer-consumer self) tag mode))) + +(defmethod end-element ((self sax-filter) (tag open-tag) mode) + (unless (sax-filter-block-p self) + (end-element (sax-producer-consumer self) tag mode))) + +(defmethod char-content ((self sax-filter) (content string) mode) + (unless (sax-filter-block-p self) + (char-content (sax-producer-consumer self) content mode))) + +(defmethod proc-instruction ((self sax-filter) (tag proc-instruction) mode) + (unless (sax-filter-block-p self) + (proc-instruction (sax-producer-consumer self) tag mode))) + +(defmethod start-document ((self sax-filter) locator) + (unless (sax-filter-block-p self) + (start-document (sax-producer-consumer self) locator))) + +(defmethod end-document ((self sax-filter) mode) + (unless (sax-filter-block-p self) + (end-document (sax-producer-consumer self) mode))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; CLASS NODE-POSITION-TRACKER +;;; + +(defclass node-position-tracker (sax-filter) + ((path-taken + :initform nil + :accessor tracker-path-taken) + (horizontal-index + :initform 0 + :accessor tracker-horizontal-index))) + +(defmethod start-element :around ((self node-position-tracker) (tag open-tag) mode) + (declare (ignore mode)) + (push (1+ (tracker-horizontal-index self)) (tracker-path-taken self)) + (setf (tracker-horizontal-index self) 0) + (call-next-method)) + +(defmethod end-element :around ((self node-position-tracker) (tag open-tag) mode) + (declare (ignore mode)) + (call-next-method) + (setf (tracker-horizontal-index self) (pop (tracker-path-taken self)))) diff --git a/src/packages.lisp b/src/packages.lisp new file mode 100644 index 0000000..0cb0727 --- /dev/null +++ b/src/packages.lisp @@ -0,0 +1,422 @@ +;;; -*- package: CL-USER; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; packages.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains the package definition for WILBUR. +;;; + + +(in-package "CL-USER") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; PACKAGE WILBUR +;;; + +(defpackage "WILBUR" + (:nicknames "W" + "NOX") ; so as not to have many packages anymore + (:use "COMMON-LISP" + #+:mcl "CCL" + #+:excl "EXCL" + #+:excl "SOCKET" + #+:excl "MOP" + #+:sbcl "SB-SYS" + #+:lispworks "MP") + (:export "*CURRENT-PARSER*" + "*DB*" + "*NAME-READER*" + "*NODES*" + "-DAML+OIL-URI-" + "-DAML-FIRST-URI-" + "-DAML-LIST-URI-" + "-DAML-NIL-URI-" + "-DAML-REST-URI-" + "-OWL-FIRST-URI-" + "-OWL-IMPORTS-URI-" + "-OWL-LIST-URI-" + "-OWL-NIL-URI-" + "-OWL-REST-URI-" + "-RDF-ABOUT-URI-" + "-RDF-ABOUTEACH-URI-" + "-RDF-ABOUTEACHPREFIX-URI-" + "-RDF-ALT-URI-" + "-RDF-ATTR-MAP-" + "-RDF-ATTRS-" + "-RDF-BAG-URI-" + "-RDF-BAGID-URI-" + "-RDF-DATATYPE-URI-" + "-RDF-DESCRIPTION-URI-" + "-RDF-ID-URI-" + "-RDF-LI-URI-" + "-RDF-NODEID-URI-" + "-RDF-OBJECT-URI-" + "-RDF-PARSETYPE-URI-" + "-RDF-PREDICATE-URI-" + "-RDF-RDF-URI-" + "-RDF-RESOURCE-URI-" + "-RDF-SEQ-URI-" + "-RDF-STATEMENT-URI-" + "-RDF-SUBJECT-URI-" + "-RDF-TYPE-URI-" + "-RDF-URI-" + "-RDFS-CLASS-URI-" + "-RDFS-COMMENT-URI-" + "-RDFS-CONSTRAINTPROPERTY-URI-" + "-RDFS-CONSTRAINTRESOURCE-URI-" + "-RDFS-CONTAINER-URI-" + "-RDFS-DOMAIN-URI-" + "-RDFS-ISDEFINEDBY-URI-" + "-RDFS-LABEL-URI-" + "-RDFS-LITERAL-URI-" + "-RDFS-RANGE-URI-" + "-RDFS-RESOURCE-URI-" + "-RDFS-SEEALSO-URI-" + "-RDFS-SUBCLASSOF-URI-" + "-RDFS-SUBPROPERTYOF-URI-" + "-RDFS-URI-" + "-WHITESPACE-CHARS-" + "-XML-LANG-ATTR-" + "ABOUT-AND-ID-BOTH-PRESENT" + "ABOUT-AND-NODEID-BOTH-PRESENT" + "ADD-NAMESPACE" + "ADD-TRIPLE" + "ADD-VALUE" + "ALL-VALUES" + "ATTACH-TO-PARENT" + "BLANK-NODE-DB-MIXIN" + "CHAR-CONTENT" + "CHAR-CONTENT" + "CLOSE-RDF-ELEMENT" + "CLOSE-TAG" + "COLLAPSE-WHITESPACE" + "COLLECT-USING-FSA" + "COMMENT" + "CONTAINER-REQUIRED" + "DAML-CONS" + "DAML-LIST" + "DAML-PARSER" + "DATE-CLEANUP-DB-MIXIN" + "DB" + "DB-ADD-TRIPLE" + "DB-BLANK-NODE-URI" + "DB-BLANK-NODE-URI-P" + "DB-CLEAR" + "DB-CLEAR-REASONER-CACHE" + "DB-DEL-SOURCE" + "DB-DEL-TRIPLE" + "DB-FIND-CBD" + "DB-FIND-SOURCE-DESC" + "DB-GET-VALUES" + "DB-INDEX-LITERALS" + "DB-INDEX-LITERALS-P" + "DB-LOAD" + "DB-LOAD-USING-SOURCE" + "DB-MAKE-TRIPLE" + "DB-MATCH-LITERALS" + "DB-MERGE" + "DB-NODE-PROPERTIES-PARTITIONED" + "DB-NODE-TYPE-P" + "DB-NODE-TYPES" + "DB-QUERY" + "DB-QUERY-BY-SOURCE" + "DB-REIFY" + "DB-RESOLVE-BLANK-NODE-URI" + "DB-RESOLVE-BLANK-NODE-URI" + "DB-SAMEAS-CLUSTERS" + "DB-SOURCE-DESCS" + "DB-SOURCE-REAL-URL" + "DB-SOURCES" + "DB-STARTUP-TIME" + "DB-SUPPORTS-MATCHING-P" + "DB-TRANSFORM-LITERAL" + "DB-TRIPLE-LOCK" + "DB-TRIPLES" + "DB-URI->BLANK-NODE" + "DEDUCTIVE-CLOSURE-DB-MIXIN" + "DEFER-TASK" + "DEFINE-READTABLE" + "DEFINE-RESOURCE-POOL" + "DEL-NAMESPACE" + "DEL-TRIPLE" + "DEL-VALUE" + "DICTIONARY" + "DICTIONARY-ADD-NAMESPACE" + "DICTIONARY-APROPOS-LIST" + "DICTIONARY-NAMESPACES" + "DICTIONARY-NODE-CLASS" + "DICTIONARY-NODES" + "DICTIONARY-REMOVE-NAMESPACE" + "DICTIONARY-RENAME-NAMESPACE" + "DICTIONARY-UNRESOLVED-NODES" + "DO-STRING-DICT" + "DOLIST+" + "DSB" + "DTD-TERMINATION-PROBLEM" + "DUPLICATE-NAMESPACE-PREFIX" + "ENABLE-LITERAL-SHORTHAND" + "ENABLE-NODE-SHORTHAND" + "END-DOCUMENT" + "END-ELEMENT" + "ENTITY-DECLARATION" + "ENTITY-NAME" + "ERROR-DEFINITION-TYPE" + "ERROR-EXPECTATION" + "ERROR-THING" + "EXECUTE-DEFERRED-TASK" + "EXPAND-NAME-WITH-NAMESPACE" + "FEATURE-NOT-SUPPORTED" + "FILE-URL" + "FIND-FIRST-PRODUCER" + "FIND-HTTP-PROXY" + "FIND-LONG-NAME" + "FIND-NODE" + "FIND-SHORT-NAME" + "FRAME" + "FRAMES-RELATED-P" + "GET-ALL-VALUES" + "GET-CANONICAL-URI" + "GET-ENTITY" + "GET-HEADER" + "GET-VALUE" + "HTTP-BODY" + "HTTP-GET" + "HTTP-HEAD" + "HTTP-HEADERS" + "HTTP-MESSAGE" + "HTTP-STATUS" + "HTTP-URL" + "HTTP-VERSION" + "ILLEGAL-CHARACTER-CONTENT" + "INDEX-URI" + "INDEX-URI-P" + "INDEXED-DB" + "INDEXED-LITERAL-DB-MIXIN" + "INTERNED-LITERAL" + "INTERNED-LITERAL-DB-MIXIN" + "INVERT-PATH" + "IS-CONTAINER-P" + "ISO8601-DATE-STRING" + "LITERAL" + "LITERAL-DATATYPE" + "LITERAL-LANGUAGE" + "LITERAL-LANGUAGE-MATCH-P" + "LITERAL-STRING" + "LITERAL-TRANSFORM-DB-MIXIN" + "LITERAL-VALUE" + "LOAD-DB" + "LOAD-DB-FROM-STREAM" + "LOCKED-DB-MIXIN" + "MAKE-CONTAINER" + "MAKE-FILE-URL" + "MAKE-HTTP-URL" + "MAKE-LOCK" + "MAKE-TRIPLE-COLLECTION" + "MAKE-URL" + "MALFORMED-URL" + "MAYBE-USE-NAMESPACE" + "MISSING-DEFINITION" + "MISSING-ENTITY-DEFINITION" + "MISSING-NAMESPACE-DEFINITION" + "NAMESPACES" + "NODE" + "NODE-NAME-RESOLVED-P" + "NODE-URI" + "OPEN-HTTP-STREAM" + "OPEN-TAG" + "OUT-OF-SEQUENCE-INDEX" + "OWL-URI" + "OWN-SLOTS" + "PARSE" + "PARSE-DB-FROM-FILE" + "PARSE-DB-FROM-STREAM" + "PARSE-EXIF-DATE" + "PARSE-FROM-FILE" + "PARSE-FROM-STREAM" + "PARSE-HTTP-DATE" + "PARSE-ISO8601-DATE" + "PARSE-URL" + "PARSE-USING-PARSETYPE" + "PARSER-DB" + "PARSER-INTERPRET-CONTENT" + "PARSER-NODE" + "PARSER-PROPERTY" + "PATH" + "PATH-EXPRESSION" + "PI-TERMINATION-PROBLEM" + "PRIORITIZE" + "PRIORITIZE-LIST" + "PROC-INSTRUCTION" + "QUERY" + "QUIT-LISP-PROCESS" + "RDF-ERROR" + "RDF-PARSER" + "RDF-SYNTAX-NORMALIZER" + "RDF-URI" + "RDFS-URI" + "READ-USING" + "REIFY" + "RELATEDP" + "REPLAY" + "REVERSE-EXPAND-NAME" + "SAX-CONSUMER" + "SAX-CONSUMER-MODE" + "SAX-CONSUMER-PRODUCER" + "SAX-FILTER" + "SAX-PRODUCER" + "SAX-PRODUCER-CONSUMER" + "SIMPLE-EXTERNAL-PROCESS" + "SOURCE-CLOSE-STREAM" + "SOURCE-DESC" + "SOURCE-DESC-LOAD-TIME" + "SOURCE-DESC-LOADED-FROM" + "SOURCE-DESC-URL" + "SOURCE-LOCATOR" + "SOURCE-MODIFICATION" + "SOURCE-OPEN-STREAM" + "SOURCE-ORIGINAL-STREAM" + "SOURCE-WITH-MODIFICATION" + "SPLIT-LIST" + "START-DOCUMENT" + "START-ELEMENT" + "STRING->KEYWORD" + "STRING-DICT-ADD" + "STRING-DICT-DEL" + "STRING-DICT-GET" + "STRING-DICT-GET-BY-VALUE" + "STRING-SOURCE" + "SYNTAX-ERROR" + "TAG-ATTRIBUTE" + "TAG-ATTRIBUTES" + "TAG-COUNTERPART" + "TAG-EMPTY-P" + "TAG-NAMESPACES" + "TASK" + "TASK-NODE" + "TASK-PARAMETER" + "TASK-TYPE" + "TOKEN" + "TOKEN-STRING" + "TREE-PARSER" + "TRIPLE" + "TRIPLE-COLLECTION-ADD" + "TRIPLE-COLLECTION-TRIPLES" + "TRIPLE-OBJECT" + "TRIPLE-PREDICATE" + "TRIPLE-SOURCES" + "TRIPLE-SUBJECT" + "TRIPLE=" + "UNEXPECTED-END-TAG" + "UNKNOWN-CHARACTER-REFERENCE" + "UNKNOWN-DECLARATION" + "UNKNOWN-PARSETYPE" + "URL" + "URL-HOST" + "URL-PATH" + "URL-PORT" + "URL-STRING" + "VALUE" + "WALK-USING-FSA" + "WITH-DB-LOCK" + "WITH-HTTP-RESPONSE" + "WITH-LOCK" + "WITH-RESOURCE-FROM-POOL" + "WITH-TEMPS" + "WITHOUT-CLOSURE" + "XML-ERROR" + "XML-FEATURE-NOT-SUPPORTED" + "XML-FORMATTER" + "XML-PARSER" + "XML-WARNING" + "XSD-URI" + + "WITH-TAGS" + "FORMAT-WITH-TAGS" + "PRINC-WITH-TAGS" + "COMMA-SEPARATED" + "XHTML-PREAMBLE" + "XML-PREAMBLE" + "WITH-RDF-PAGE" + "ESCAPE-JSON-STRING" + "ESCAPE-XML-STRING" + "SERIALIZER" + "SERIALIZER-STREAM" + "SERIALIZER-DUMP" + "SINGLE-SUBJECT-TRIPLES" + "RDF/XML-SERIALIZER")) diff --git a/src/platform.lisp b/src/platform.lisp new file mode 100644 index 0000000..992f119 --- /dev/null +++ b/src/platform.lisp @@ -0,0 +1,165 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; platform.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: This file contains various platform-dependent functions and macros. +;;; Currently, we support MCL, OpenMCL, Allegro and SBCL. There is no reason why Wilbur +;;; wouldn't run on other Common Lisps too, but some of these functions will have to be +;;; ported separately. +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; FEATURES, PACKAGES, ETC. +;;; + +#+(and :mcl (not :openmcl)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (pushnew :realmcl *features*) + (require :opentransport)) + +#+(or :excl :sbcl) +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; adding this feature suppresses other HTTP client implementations + (pushnew :http-using-aserve *features*) + ;; other implementations may have other means of installing Portable AServe + (require :aserve)) + +#+:excl +(eval-when (:compile-toplevel :load-toplevel :execute) + (import '(mp:process-kill mp:process-wait mp:process-run-function))) + +#+:sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (import '(sb-ext:process-wait))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (pushnew :wilbur *features*) + (pushnew :wilbur2 *features*)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LOCKS +;;; + +#-(and :mcl :CCL-5.2) ; already defined +(defmacro with-lock ((lock &rest args) &body body) + #+:mcl `(with-lock-grabbed (,lock ,@args) ,@body) + #+:excl `(mp:with-process-lock (,lock ,@args) ,@body) + #+:sbcl `(sb-thread:with-recursive-lock (,lock ,@args) ,@body) + #-(or :mcl :excl :sbcl :lispworks) (error "No locking defined (WITH-LOCK)")) + +#-(or :mcl :lispworks) ; already implemented in MCL and LW +(defun make-lock () + #+:excl (mp:make-process-lock) + #+:sbcl (sb-thread:make-mutex) + #-(or :excl :sbcl) (error "No locking implemented")) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; EXTERNAL PROCESSES, ETC. +;;; + +(defun simple-external-process (cmd &rest args) + (declare (dynamic-extent args)) + #+:openmcl (external-process-output-stream + (run-program cmd (remove nil args) :output :stream :wait nil)) + #+:excl (run-shell-command (format nil "~A~{~@[ '~A'~]~}" cmd args) + :output :stream :wait nil) + #+:sbcl (sb-ext:process-output + (sb-ext:run-program cmd (remove nil args) :output :stream :wait nil)) + #-(or :openmcl :excl :sbcl) + (error "Cannot execute \"~A~{~@[ ~A~]~}\". No external processes" cmd args)) + +(defun quit-lisp-process () + #+:openmcl (ccl:quit) + #+:excl (excl:exit) + #+:sbcl (sb-ext:quit) + #-(or :openmcl :excl :sbcl) (warn "Don't know how to quit Lisp")) + +(defun get-env (key) + #+:openmcl (ccl:getenv key) + #+:excl (sys:getenv key) + #+:sbcl (sb-ext:posix-getenv (string key)) + #-(or :openmcl :excl :sbcl) (error "Cannot get the environment variable ~S" key)) diff --git a/src/useful.lisp b/src/useful.lisp new file mode 100644 index 0000000..402b86e --- /dev/null +++ b/src/useful.lisp @@ -0,0 +1,199 @@ +;;; -*- package: WILBUR; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; useful.lisp +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: Useful functions and macros +;;; + + +(in-package "WILBUR") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; GENERALLY USEFUL STUFF +;;; + +(defmacro with-temps ((&rest variables) &body body) + `(let (,@(mapcar #'(lambda (variable) + `(,variable (gentemp))) + variables)) + ,@body)) + +(defmacro dolist+ ((pattern list &optional (value nil value-supplied-p)) &body body) + (if (symbolp pattern) + `(dolist (,pattern ,list ,@(and value-supplied-p (list value))) + ,@body) + (let ((i (gentemp))) + `(dolist (,i ,list ,@(and value-supplied-p (list value))) + (destructuring-bind ,pattern ,i + ,@body))))) + +(defmacro dsb (pattern form &body body) + `(destructuring-bind ,pattern ,form ,@body)) + +(defun remove-weird (sequence item &rest options) + (declare (dynamic-extent options)) + (apply #'remove item sequence options)) + +(defun delete-weird (sequence item &rest options) + (declare (dynamic-extent options)) + (apply #'delete item sequence options)) + +(define-modify-macro removef (items &rest options) remove-weird) + +(define-modify-macro deletef (items &rest options) delete-weird) + +(define-modify-macro unionf (items) union) + +(defun eq~ (x y) + (or (null x) + (null y) + (eq x y))) + +(declaim (inline eq~)) + +(defun string->keyword (string &optional (package :keyword)) + (if package (intern (string-upcase string) package) string)) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; STRING DICTIONARY +;;; +;;; Some care must be taken when using this, since (in the interest of making the +;;; implementation not cons so much) we have used destructive operations. +;;; + +(defun string-dict-get (keys&values key) + (cdr (assoc key keys&values :test #'string=))) + +(defun string-dict-get-by-value (keys&values value) + (car (rassoc value keys&values :test #'string=))) + +(defun string-dict-add (keys&values key value) + (acons key value keys&values)) + +(defun string-dict-del (keys&values key) + (delete key keys&values :key #'car :test #'string=)) + +(defmacro do-string-dict ((key value dict) &body body) + `(loop for (,key . ,value) in ,dict do (progn ,@body))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LIST MANIPULATION +;;; + +(defun split-list (head tail n &optional (no-split-p nil)) + (if no-split-p + (values tail nil) + (if (and tail (plusp n)) + (split-list (cons (first tail) head) (rest tail) (1- n) no-split-p) + (values (nreverse head) tail)))) + +(defun prioritize-list (list possible-priority-items + &key (test #'eql) (key #'identity)) + (prioritize list :prefer possible-priority-items :test test :key key)) + +(defun prioritize (list + &key (prefer nil) + (exclude nil) + (test #'eql) + (key #'identity) + (splitp nil)) + (let* ((items (remove-if #'(lambda (item) + (find-if #'(lambda (e) + (funcall test e (funcall key item))) + exclude)) + list)) + (priority-items (mapcan #'(lambda (p) + (let ((item (find p items :test test :key key))) + (and item (list item)))) + prefer)) + (other-items (remove-if #'(lambda (item) + (find-if #'(lambda (p) + (funcall test + (funcall key p) + (funcall key item))) + priority-items)) + items))) + (if splitp + (values priority-items other-items) + (append priority-items other-items)))) diff --git a/src/wilbur.asd b/src/wilbur.asd new file mode 100644 index 0000000..f6e67ff --- /dev/null +++ b/src/wilbur.asd @@ -0,0 +1,209 @@ +;;; -*- mode: lisp; package: ASDF; Syntax: Common-lisp; Base: 10 -*- + +;;; +;;;; wilbur.asd +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; The Original Software is +;;; WILBUR2: Nokia Semantic Web Toolkit for CLOS +;;; +;;; Copyright (c) 2001-2009 Nokia Corp. and/or its subsidiaries. All Rights Reserved. +;;; Portions Copyright (c) 1989-1992 Ora Lassila. All Rights Reserved. +;;; +;;; Contributor(s): Ora Lassila (mailto:ora.lassila@nokia.com) +;;; +;;; This program is licensed under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation, version 2.1 of the License. Note +;;; however that a preamble attached below also applies to this program. +;;; +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; Preamble to the Gnu Lesser General Public License +;;; +;;; Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 +;;; +;;; The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been +;;; adopted to govern the use and distribution of above-mentioned application. However, +;;; the LGPL uses terminology that is more appropriate for a program written in C than +;;; one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program +;;; if certain clarifications are made. This document details those clarifications. +;;; Accordingly, the license for the open-source Lisp applications consists of this +;;; document plus the LGPL. Wherever there is a conflict between this document and the +;;; LGPL, this document takes precedence over the LGPL. +;;; +;;; A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. +;;; The form of the Library can be Lisp source code (for processing by an interpreter) +;;; or object code (usually the result of compilation of source code or built with some +;;; other mechanisms). Foreign modules are object code in a form that can be linked +;;; into a Lisp executable. When we speak of functions we do so in the most general way +;;; to include, in addition, methods and unnamed functions. Lisp "data" is also a +;;; general term that includes the data structures resulting from defining Lisp classes. +;;; A Lisp application may include the same set of Lisp objects as does a Library, but +;;; this does not mean that the application is necessarily a "work based on the Library" +;;; it contains. +;;; +;;; The Library consists of everything in the distribution file set before any +;;; modifications are made to the files. If any of the functions or classes in the +;;; Library are redefined in other files, then those redefinitions ARE considered a +;;; work based on the Library. If additional methods are added to generic functions in +;;; the Library, those additional methods are NOT considered a work based on the +;;; Library. If Library classes are subclassed, these subclasses are NOT considered a +;;; work based on the Library. If the Library is modified to explicitly call other +;;; functions that are neither part of Lisp itself nor an available add-on module to +;;; Lisp, then the functions called by the modified Library ARE considered a work based +;;; on the Library. The goal is to ensure that the Library will compile and run without +;;; getting undefined function errors. +;;; +;;; It is permitted to add proprietary source code to the Library, but it must be done +;;; in a way such that the Library will still run without that proprietary code present. +;;; Section 5 of the LGPL distinguishes between the case of a library being dynamically +;;; linked at runtime and one being statically linked at build time. Section 5 of the +;;; LGPL states that the former results in an executable that is a "work that uses the +;;; Library." Section 5 of the LGPL states that the latter results in one that is a +;;; "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only +;;; offers one choice, which is to link the Library into an executable at build time, we +;;; declare that, for the purpose applying the LGPL to the Library, an executable that +;;; results from linking a "work that uses the Library" with the Library is considered a +;;; "work that uses the Library" and is therefore NOT covered by the LGPL. +;;; +;;; Because of this declaration, section 6 of LGPL is not applicable to the Library. +;;; However, in connection with each distribution of this executable, you must also +;;; deliver, in accordance with the terms and conditions of the LGPL, the source code +;;; of Library (or your derivative thereof) that is incorporated into this executable. +;;; +;;; -------------------------------------------------------------------------------------- +;;; +;;; +;;; Purpose: System definition(s) for Wilbur2 +;;; +;;; We no longer support either The CMU Defsystem (by Mark Kantrowitz) nor Franz, +;;; Inc.'s defsystem (as shipped with Allegro Common Lisp). Instead, after a lot of +;;; "soul-searching" we -- perhaps a little reluctantly -- have decided to go with +;;; ASDF. It seems to have become the norm. For your convenience, the function +;;; MAKE-WILBUR has been defined (internal in the CL-USER package). +;;; +;;; Wilbur relies on the logical pathname host "wilbur". Here's a sample of how to set +;;; up the pathname translations on a Unix-style system: +;;; +;;; (("base;**;*.*" "/Users/ora/Wilbur/**/*.*") ; this line is the example part +;;; ("nox;*.*" "wilbur:base;src;nox;*.*") +;;; ("core;*.*" "wilbur:base;src;core;*.*") +;;; ("goodies;*.*" "wilbur:base;src;goodies;*.*") +;;; ("libs;**;*.*" "wilbur:base;src;libs;**;*.*") +;;; ("doc;*.*" "wilbur:base;doc;*.*") +;;; ("schemata;*.*" "wilbur:base;schemata;*.*")) +;;; +;;; There's code below that attempts to define the above rules. It is not always easy +;;; to understand how the Common Lisp logical pathname translations work. Please check +;;; the translations (using TRANSLATE-LOGICAL-PATHNAME) before assuming that there are +;;; bugs in Wilbur. :-) +;;; + + +(in-package "ASDF") + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; COMPATIBILITY STUFF +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; OK, this is a hack, but here goes anyway... + (when (find-package "UFFI") + (pushnew :uffi *features*)) + ;;#+:sbcl + ;;(pushnew :piglet *features*) + ) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; LOGICAL PATHNAME STUFF +;;; + +(eval-when (:load-toplevel :compile-toplevel :execute) + (let* ((p (probe-file *load-pathname*)) + (d (pathname-directory p))) + (setf (logical-pathname-translations "wilbur") + `(("base;**;*.*" + ,(merge-pathnames (make-pathname :name :wild :type :wild :version :wild + :directory '(:relative :wild-inferiors)) + (make-pathname :name nil :type nil + :directory (subseq d 0 (1- (length d))) + :defaults p))) + ("nox;*.*" "wilbur:base;src;nox;*.*") + ("core;*.*" "wilbur:base;src;core;*.*") + ("goodies;*.*" "wilbur:base;src;goodies;*.*") + ("libs;**;*.*" "wilbur:base;src;libs;**;*.*") + ("doc;*.*" "wilbur:base;doc;*.*") + ("schemata;*.*" "wilbur:base;schemata;*.*"))) + (format t "~&; \"wilbur:base;\" = ~A~%" (translate-logical-pathname "wilbur:base;")))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; ASDF SYSTEM DEFINITION FOR WILBUR2 +;;; + +(defsystem :wilbur + :name "wilbur" + :author "Ora Lassila mailto:ora.lassila@nokia.com" + :version "2" + :licence "NOKOS 1.0a" + :description "WILBUR2: Nokia's Semantic Web Toolkit for CLOS" + :components ((:file "packages") + (:file "platform" :depends-on ("packages")) + (:file "useful" :depends-on ("packages")) + (:module :nox + :components ((:file "core-constants") + (:file "xml-util" :depends-on ("core-constants")) + (:file "xml-parser" :depends-on ("xml-util"))) + :depends-on ("packages" "platform" "useful")) + (:module :core + :components ((:file "hash-table") + (:file "data" :depends-on ("hash-table")) + (:file "literal" :depends-on ("data")) + (:file "rdf-parser" :depends-on ("data" "literal")) + (:file "http") + (:file "data-sources" :depends-on ("data" "http")) + (:file "wilbur-ql" :depends-on ("data" "literal")) + (:file "reasoner" :depends-on ("wilbur-ql"))) + :depends-on (:nox)) + (:module :goodies + :components ((:file "serializer") + #+:realmcl + (:file "rdf-inspector" :depends-on ("serializer")) + ;; (:file "ivanhoe") + (:file "db-additions") + (:file "index-and-match")) + :depends-on (:nox :core)))) + + +;;; -------------------------------------------------------------------------------------- +;;; +;;; HOPEFULLY USEFUL STUFF +;;; + +(defun cl-user::build-system (system &key (asd nil) (compilep nil)) + ;; OK, notice we have a HANDLER-BIND here... I give up, I cannot figure out + ;; how the constant definition process works on SBCL. Perhaps that's the way + ;; ANSI CL is supposed to work, but it seems difficult to get it right. I + ;; find it easier to just suppress the "constant-redefined-with-new-value" + ;; errors :-) + (handler-bind (#+:sbcl (sb-ext:defconstant-uneql #'continue)) + (when asd + (load asd)) + (asdf:operate (if compilep 'asdf:compile-op 'asdf:load-op) system))) + +(defun cl-user::make-wilbur (&key (compilep nil)) + (cl-user::build-system :wilbur :compilep compilep)) + +;;; comment out if you want triples to be structs instead of class instances +(pushnew :wilbur-triples-as-classes *features*) + +#+:allegro +(pushnew :wilbur-own-hashtables *features*)