/src/yolk-syndication.adb

http://github.com/ThomasLocke/yolk · Ada · 551 lines · 352 code · 87 blank · 112 comment · 18 complexity · 6791835e80893e9a87883e4d24f0cac6 MD5 · raw file

  1. -------------------------------------------------------------------------------
  2. -- --
  3. -- Copyright (C) 2010-, Thomas ¸cke --
  4. -- --
  5. -- This library is free software; you can redistribute it and/or modify --
  6. -- it under terms of the GNU General Public License as published by the --
  7. -- Free Software Foundation; either version 3, or (at your option) any --
  8. -- later version. This library is distributed in the hope that it will be --
  9. -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
  10. -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
  11. -- --
  12. -- As a special exception under Section 7 of GPL version 3, you are --
  13. -- granted additional permissions described in the GCC Runtime Library --
  14. -- Exception, version 3.1, as published by the Free Software Foundation. --
  15. -- --
  16. -- You should have received a copy of the GNU General Public License and --
  17. -- a copy of the GCC Runtime Library Exception along with this program; --
  18. -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
  19. -- <http://www.gnu.org/licenses/>. --
  20. -- --
  21. -------------------------------------------------------------------------------
  22. with Ada.Streams;
  23. with DOM.Core.Nodes;
  24. with Yolk.Syndication.DOM_Builder;
  25. package body Yolk.Syndication is
  26. -------------------
  27. -- Equal_Entry --
  28. -------------------
  29. function Equal_Entry
  30. (Left, Right : in Atom_Entry)
  31. return Boolean
  32. is
  33. begin
  34. return Left.Id.URI = Right.Id.URI;
  35. end Equal_Entry;
  36. ----------------------
  37. -- New_Atom_Entry --
  38. ----------------------
  39. function New_Atom_Entry
  40. (Base_URI : in String := None;
  41. Language : in String := None)
  42. return Atom_Entry
  43. is
  44. begin
  45. return An_Entry : Atom_Entry := Null_Atom_Entry do
  46. if Base_URI /= None then
  47. An_Entry.Common.Base_URI := U (Base_URI);
  48. end if;
  49. if Language /= None then
  50. An_Entry.Common.Language := U (Language);
  51. end if;
  52. end return;
  53. end New_Atom_Entry;
  54. -----------------------------
  55. -- New_Atom_Entry_Source --
  56. -----------------------------
  57. function New_Atom_Entry_Source
  58. (Base_URI : in String := None;
  59. Language : in String := None)
  60. return Atom_Entry_Source
  61. is
  62. begin
  63. return Source : Atom_Entry_Source := Null_Atom_Entry_Source do
  64. if Base_URI /= None then
  65. Source.Common.Base_URI := U (Base_URI);
  66. end if;
  67. if Language /= None then
  68. Source.Common.Language := U (Language);
  69. end if;
  70. null;
  71. end return;
  72. end New_Atom_Entry_Source;
  73. ---------------------
  74. -- New_Atom_Feed --
  75. ---------------------
  76. function New_Atom_Feed
  77. (Base_URI : in String := None;
  78. Language : in String := None;
  79. Max_Age : in Duration := 5_616_000.0;
  80. Max_Entries : in Positive := 100;
  81. Min_Entries : in Positive := 10)
  82. return Atom_Feed
  83. is
  84. Common : constant Atom_Common := (Base_URI => U (Base_URI),
  85. Language => U (Language));
  86. begin
  87. return Feed : Atom_Feed do
  88. Feed.PAF.Set_Common (Value => Common);
  89. Feed.PAF.Set_Max_age (Value => Max_Age);
  90. Feed.PAF.Set_Max_Entries (Value => Max_Entries);
  91. Feed.PAF.Set_Min_Entries (Value => Min_Entries);
  92. end return;
  93. end New_Atom_Feed;
  94. ---------------------------
  95. -- Protected_Atom_Feed --
  96. ---------------------------
  97. protected body Protected_Atom_Feed is
  98. ------------------
  99. -- Add_Author --
  100. ------------------
  101. procedure Add_Author
  102. (Value : in Atom_Person)
  103. is
  104. begin
  105. Authors.Append (Value);
  106. end Add_Author;
  107. --------------------
  108. -- Add_Category --
  109. --------------------
  110. procedure Add_Category
  111. (Value : in Atom_Category)
  112. is
  113. begin
  114. Categories.Append (Value);
  115. end Add_Category;
  116. -----------------------
  117. -- Add_Contributor --
  118. -----------------------
  119. procedure Add_Contributor
  120. (Value : in Atom_Person)
  121. is
  122. begin
  123. Contributors.Append (Value);
  124. end Add_Contributor;
  125. -----------------
  126. -- Add_Entry --
  127. -----------------
  128. procedure Add_Entry
  129. (Value : in Yolk.Syndication.Atom_Entry)
  130. is
  131. use Ada.Calendar;
  132. use Entry_List;
  133. procedure Insert_Entry
  134. (Value : in Atom_Entry;
  135. Done : out Boolean);
  136. -- Insert the Value into List sorted by Atom_Entry.Updated
  137. --------------------
  138. -- Insert_Entry --
  139. --------------------
  140. procedure Insert_Entry
  141. (Value : in Atom_Entry;
  142. Done : out Boolean)
  143. is
  144. Appendable : Boolean := False;
  145. C : Cursor;
  146. begin
  147. if Entries.Is_Empty then
  148. Appendable := True;
  149. else
  150. if Value.Updated.Time_Stamp <=
  151. Entries.Last_Element.Updated.Time_Stamp
  152. then
  153. Appendable := True;
  154. end if;
  155. end if;
  156. if Appendable then
  157. Entries.Append (New_Item => Value);
  158. Done := True;
  159. elsif Value.Updated.Time_Stamp >=
  160. Entries.First_Element.Updated.Time_Stamp
  161. then
  162. Entries.Prepend (New_Item => Value);
  163. Done := True;
  164. else
  165. C := Entries.First;
  166. while Has_Element (C) loop
  167. if Value.Updated.Time_Stamp >=
  168. Element (C).Updated.Time_Stamp
  169. then
  170. Entries.Insert (Before => C,
  171. New_Item => Value);
  172. Done := True;
  173. exit;
  174. end if;
  175. Next (C);
  176. end loop;
  177. end if;
  178. end Insert_Entry;
  179. C : Cursor;
  180. Counter : Natural := Natural (Entries.Length);
  181. Entry_Added : Boolean := False;
  182. Now : constant Time := Clock;
  183. begin
  184. C := Find (Container => Entries,
  185. Item => Value);
  186. if C /= No_Element then
  187. Entries.Delete (Position => C);
  188. end if;
  189. if Entries.Length >= Count_Type (Max_Entries) then
  190. Entries.Delete_Last
  191. (Count => Entries.Length - (Count_Type (Max_Entries - 1)));
  192. end if;
  193. C := Entries.Last;
  194. loop
  195. exit when Counter <= Min_Entries;
  196. if Now - Element (C).Updated.Time_Stamp > Max_Entry_Age then
  197. Entries.Delete (Position => C);
  198. C := Entries.Last;
  199. else
  200. Previous (C);
  201. end if;
  202. Counter := Counter - 1;
  203. end loop;
  204. if Entries.Length < Count_Type (Max_Entries)
  205. or Clock - Value.Updated.Time_Stamp <= Max_Entry_Age
  206. then
  207. Insert_Entry (Value => Value,
  208. Done => Entry_Added);
  209. end if;
  210. if Entry_Added
  211. and then Value.Updated.Time_Stamp < Updated.Time_Stamp
  212. then
  213. Updated.Time_Stamp := Value.Updated.Time_Stamp;
  214. end if;
  215. end Add_Entry;
  216. ----------------
  217. -- Add_Link --
  218. ----------------
  219. procedure Add_Link
  220. (Value : in Atom_Link)
  221. is
  222. begin
  223. Links.Append (Value);
  224. end Add_Link;
  225. -------------------------
  226. -- Amount_Of_Entries --
  227. -------------------------
  228. function Amount_Of_Entries return Natural
  229. is
  230. begin
  231. return Natural (Entries.Length);
  232. end Amount_Of_Entries;
  233. ------------------------
  234. -- Clear_Entry_List --
  235. ------------------------
  236. procedure Clear_Entry_List
  237. is
  238. begin
  239. Entries.Clear;
  240. end Clear_Entry_List;
  241. --------------------
  242. -- Delete_Entry --
  243. --------------------
  244. procedure Delete_Entry
  245. (Id : in String)
  246. is
  247. use Entry_List;
  248. C : Cursor;
  249. begin
  250. C := Entries.First;
  251. while Has_Element (C) loop
  252. if Element (C).Id.URI = U (Id) then
  253. Entries.Delete (C);
  254. end if;
  255. Next (C);
  256. end loop;
  257. end Delete_Entry;
  258. ---------------
  259. -- Get_DOM --
  260. ---------------
  261. function Get_DOM return DOM.Core.Document
  262. is
  263. use DOM.Core;
  264. use Yolk.Syndication.DOM_Builder;
  265. Doc : Document;
  266. Impl : DOM_Implementation;
  267. begin
  268. Doc := Create_Document (Implementation => Impl);
  269. Create_Feed_Element (Authors => Authors,
  270. Categories => Categories,
  271. Common => Common,
  272. Contributors => Contributors,
  273. Doc => Doc,
  274. Entries => Entries,
  275. Generator => Generator,
  276. Icon => Icon,
  277. Id => Id,
  278. Links => Links,
  279. Logo => Logo,
  280. Rights => Rights,
  281. Subtitle => Subtitle,
  282. Title => Title,
  283. Updated => Updated);
  284. return Doc;
  285. end Get_DOM;
  286. ------------------
  287. -- Get_String --
  288. ------------------
  289. function Get_String
  290. (Pretty_Print : in Boolean := False)
  291. return String
  292. is
  293. use Ada.Streams;
  294. use DOM.Core.Nodes;
  295. type String_Stream_Type is new Root_Stream_Type with record
  296. Str : Unbounded_String;
  297. Read_Index : Natural := 1;
  298. end record;
  299. procedure Read
  300. (Stream : in out String_Stream_Type;
  301. Item : out Stream_Element_Array;
  302. Last : out Stream_Element_Offset);
  303. procedure Write
  304. (Stream : in out String_Stream_Type;
  305. Item : Stream_Element_Array);
  306. ----------
  307. -- Read --
  308. ----------
  309. procedure Read
  310. (Stream : in out String_Stream_Type;
  311. Item : out Stream_Element_Array;
  312. Last : out Stream_Element_Offset)
  313. is
  314. Str : constant String := Slice
  315. (Stream.Str,
  316. Stream.Read_Index,
  317. Stream.Read_Index + Item'Length - 1);
  318. J : Stream_Element_Offset := Item'First;
  319. begin
  320. for S in Str'Range loop
  321. Item (J) := Stream_Element (Character'Pos (Str (S)));
  322. J := J + 1;
  323. end loop;
  324. Last := Item'First + Str'Length - 1;
  325. Stream.Read_Index := Stream.Read_Index + Item'Length;
  326. end Read;
  327. -----------
  328. -- Write --
  329. -----------
  330. procedure Write
  331. (Stream : in out String_Stream_Type;
  332. Item : Stream_Element_Array)
  333. is
  334. Str : String (1 .. Integer (Item'Length));
  335. S : Integer := Str'First;
  336. begin
  337. for J in Item'Range loop
  338. Str (S) := Character'Val (Item (J));
  339. S := S + 1;
  340. end loop;
  341. Append (Stream.Str, Str);
  342. end Write;
  343. Output : aliased String_Stream_Type;
  344. Doc : DOM.Core.Document := Get_DOM;
  345. begin
  346. DOM.Core.Nodes.Write (Stream => Output'Access,
  347. N => Doc,
  348. Print_Comments => False,
  349. Print_XML_Declaration => False,
  350. Pretty_Print => Pretty_Print);
  351. Free (Doc);
  352. return PI & To_String (Output.Str);
  353. end Get_String;
  354. ------------------
  355. -- Set_Common --
  356. ------------------
  357. procedure Set_Common
  358. (Value : in Atom_Common)
  359. is
  360. begin
  361. Common := Value;
  362. end Set_Common;
  363. ---------------------
  364. -- Set_Generator --
  365. ---------------------
  366. procedure Set_Generator
  367. (Value : in Atom_Generator)
  368. is
  369. begin
  370. Generator := Value;
  371. end Set_Generator;
  372. ----------------
  373. -- Set_Icon --
  374. ----------------
  375. procedure Set_Icon
  376. (Value : in Atom_Icon)
  377. is
  378. begin
  379. Icon := Value;
  380. end Set_Icon;
  381. --------------
  382. -- Set_Id --
  383. --------------
  384. procedure Set_Id
  385. (Value : in Atom_Id)
  386. is
  387. begin
  388. Id := Value;
  389. end Set_Id;
  390. ----------------
  391. -- Set_Logo --
  392. ----------------
  393. procedure Set_Logo
  394. (Value : in Atom_Logo)
  395. is
  396. begin
  397. Logo := Value;
  398. end Set_Logo;
  399. -------------------
  400. -- Set_Max_Age --
  401. -------------------
  402. procedure Set_Max_Age
  403. (Value : in Duration)
  404. is
  405. begin
  406. Max_Entry_Age := Value;
  407. end Set_Max_Age;
  408. -----------------------
  409. -- Set_Max_Entries --
  410. -----------------------
  411. procedure Set_Max_Entries
  412. (Value : in Positive)
  413. is
  414. begin
  415. Max_Entries := Value;
  416. end Set_Max_Entries;
  417. -----------------------
  418. -- Set_Min_Entries --
  419. -----------------------
  420. procedure Set_Min_Entries
  421. (Value : in Positive)
  422. is
  423. begin
  424. Min_Entries := Value;
  425. end Set_Min_Entries;
  426. ------------------
  427. -- Set_Rights --
  428. ------------------
  429. procedure Set_Rights
  430. (Value : in Atom_Text)
  431. is
  432. begin
  433. Rights := Value;
  434. end Set_Rights;
  435. --------------------
  436. -- Set_Subtitle --
  437. --------------------
  438. procedure Set_Subtitle
  439. (Value : in Atom_Text)
  440. is
  441. begin
  442. Subtitle := Value;
  443. end Set_Subtitle;
  444. -----------------
  445. -- Set_Title --
  446. -----------------
  447. procedure Set_Title
  448. (Value : Atom_Text)
  449. is
  450. begin
  451. Title := Value;
  452. end Set_Title;
  453. -------------------
  454. -- Set_Updated --
  455. -------------------
  456. procedure Set_Updated_Time
  457. (Value : in Atom_Date)
  458. is
  459. use Ada.Calendar;
  460. begin
  461. Updated := Value;
  462. end Set_Updated_Time;
  463. end Protected_Atom_Feed;
  464. end Yolk.Syndication;