1------------------------------------------------------------------------------
2--                                                                          --
3--                            Matreshka Project                             --
4--                                                                          --
5--                               XML Processor                              --
6--                                                                          --
7--                        Runtime Library Component                         --
8--                                                                          --
9------------------------------------------------------------------------------
10--                                                                          --
11-- Copyright © 2010-2011, Vadim Godunko <vgodunko@gmail.com>                --
12-- All rights reserved.                                                     --
13--                                                                          --
14-- Redistribution and use in source and binary forms, with or without       --
15-- modification, are permitted provided that the following conditions       --
16-- are met:                                                                 --
17--                                                                          --
18--  * Redistributions of source code must retain the above copyright        --
19--    notice, this list of conditions and the following disclaimer.         --
20--                                                                          --
21--  * Redistributions in binary form must reproduce the above copyright     --
22--    notice, this list of conditions and the following disclaimer in the   --
23--    documentation and/or other materials provided with the distribution.  --
24--                                                                          --
25--  * Neither the name of the Vadim Godunko, IE nor the names of its        --
26--    contributors may be used to endorse or promote products derived from  --
27--    this software without specific prior written permission.              --
28--                                                                          --
29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      --
30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        --
31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR    --
32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT     --
33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,   --
34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR   --
36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF   --
37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING     --
38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS       --
39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.             --
40--                                                                          --
41------------------------------------------------------------------------------
42--  $Revision: 2135 $ $Date: 2011-10-09 23:01:29 +0400 (Sun, 09 Oct 2011) $
43------------------------------------------------------------------------------
44with Ada.Unchecked_Deallocation;
45
46with League.Strings.Internals;
47with Matreshka.Internals.Strings.Configuration;
48
49package body XML.SAX.Attributes is
50
51   use League.Strings;
52   use Matreshka.Internals.Strings.Configuration;
53
54   procedure Free is
55     new Ada.Unchecked_Deallocation
56          (Shared_Attributes, Shared_Attributes_Access);
57
58   ------------
59   -- Adjust --
60   ------------
61
62   overriding procedure Adjust (Self : in out SAX_Attributes) is
63   begin
64      Reference (Self.Data);
65   end Adjust;
66
67   -------------------
68   -- Can_Be_Reused --
69   -------------------
70
71   function Can_Be_Reused (Self : Shared_Attributes_Access) return Boolean is
72   begin
73      return Matreshka.Atomics.Counters.Is_One (Self.Counter);
74   end Can_Be_Reused;
75
76   -----------
77   -- Clear --
78   -----------
79
80   procedure Clear (Self : in out SAX_Attributes'Class) is
81   begin
82      if Can_Be_Reused (Self.Data) then
83         for J in 1 .. Self.Data.Length loop
84            Matreshka.Internals.Strings.Dereference
85             (Self.Data.Values (J).Namespace_URI);
86            Matreshka.Internals.Strings.Dereference
87             (Self.Data.Values (J).Local_Name);
88            Matreshka.Internals.Strings.Dereference
89             (Self.Data.Values (J).Qualified_Name);
90            Matreshka.Internals.Strings.Dereference
91             (Self.Data.Values (J).Value);
92            Matreshka.Internals.Strings.Dereference
93             (Self.Data.Values (J).Value_Type);
94         end loop;
95
96         Self.Data.Length := 0;
97
98      else
99         Dereference (Self.Data);
100         Self.Data := new Shared_Attributes (8);
101      end if;
102   end Clear;
103
104   -----------------
105   -- Dereference --
106   -----------------
107
108   procedure Dereference (Self : in out Shared_Attributes_Access) is
109   begin
110      if Self /= Shared_Empty'Access then
111         if Matreshka.Atomics.Counters.Decrement (Self.Counter) then
112            for J in 1 .. Self.Length loop
113               Matreshka.Internals.Strings.Dereference
114                (Self.Values (J).Namespace_URI);
115               Matreshka.Internals.Strings.Dereference
116                (Self.Values (J).Local_Name);
117               Matreshka.Internals.Strings.Dereference
118                (Self.Values (J).Qualified_Name);
119               Matreshka.Internals.Strings.Dereference
120                (Self.Values (J).Value);
121               Matreshka.Internals.Strings.Dereference
122                (Self.Values (J).Value_Type);
123            end loop;
124
125            Free (Self);
126
127         else
128            Self := null;
129         end if;
130      end if;
131   end Dereference;
132
133   ------------
134   -- Detach --
135   ------------
136
137   procedure Detach (Self : in out Shared_Attributes_Access; Size : Natural) is
138   begin
139      --  Reallocate shared object when necessary.
140
141      if not Can_Be_Reused (Self)
142         --  Object can't be mutated because someone else use it. Allocate
143         --  new shared object and copy data.
144        or else Self.Last < Size
145         --  There are no enought space to store new attribute. Reallocate new
146         --  object and copy data.
147      then
148         declare
149            Aux : constant Shared_Attributes_Access
150              := new Shared_Attributes ((Size + 8) / 8 * 8);
151
152         begin
153            Aux.Values (1 .. Self.Length) := Self.Values (1 .. Self.Length);
154            Aux.Length := Self.Length;
155
156            for J in 1 .. Aux.Length loop
157               Matreshka.Internals.Strings.Reference
158                (Aux.Values (J).Namespace_URI);
159               Matreshka.Internals.Strings.Reference
160                (Aux.Values (J).Local_Name);
161               Matreshka.Internals.Strings.Reference
162                (Aux.Values (J).Qualified_Name);
163               Matreshka.Internals.Strings.Reference
164                (Aux.Values (J).Value);
165               Matreshka.Internals.Strings.Reference
166                (Aux.Values (J).Value_Type);
167            end loop;
168
169            Dereference (Self);
170            Self := Aux;
171         end;
172      end if;
173   end Detach;
174
175   --------------
176   -- Finalize --
177   --------------
178
179   overriding procedure Finalize (Self : in out SAX_Attributes) is
180   begin
181      if Self.Data /= null then
182         Dereference (Self.Data);
183      end if;
184   end Finalize;
185
186   -----------
187   -- Index --
188   -----------
189
190   function Index
191    (Self           : SAX_Attributes'Class;
192     Qualified_Name : League.Strings.Universal_String) return Natural is
193   begin
194      for J in 1 .. Self.Data.Length loop
195         if String_Handler.Is_Equal
196             (Self.Data.Values (J).Qualified_Name,
197              League.Strings.Internals.Internal (Qualified_Name))
198         then
199            return J;
200         end if;
201      end loop;
202
203      return 0;
204   end Index;
205
206   -----------
207   -- Index --
208   -----------
209
210   function Index
211    (Self          : SAX_Attributes'Class;
212     Namespace_URI : League.Strings.Universal_String;
213     Local_Name    : League.Strings.Universal_String) return Natural is
214   begin
215      for J in 1 .. Self.Data.Length loop
216         if String_Handler.Is_Equal
217             (Self.Data.Values (J).Namespace_URI,
218              League.Strings.Internals.Internal (Namespace_URI))
219           and String_Handler.Is_Equal
220                (Self.Data.Values (J).Local_Name,
221                 League.Strings.Internals.Internal (Local_Name))
222         then
223            return J;
224         end if;
225      end loop;
226
227      return 0;
228   end Index;
229
230   -----------------
231   -- Is_Declared --
232   -----------------
233
234   function Is_Declared
235    (Self  : SAX_Attributes'Class;
236     Index : Positive) return Boolean is
237   begin
238      if Index > Self.Data.Length then
239         raise Constraint_Error;
240      end if;
241
242      return Self.Data.Values (Index).Is_Declared;
243   end Is_Declared;
244
245   -----------------
246   -- Is_Declared --
247   -----------------
248
249   function Is_Declared
250    (Self           : SAX_Attributes'Class;
251     Qualified_Name : League.Strings.Universal_String)
252       return Boolean is
253   begin
254      for J in 1 .. Self.Data.Length loop
255         if String_Handler.Is_Equal
256             (Self.Data.Values (J).Qualified_Name,
257              League.Strings.Internals.Internal (Qualified_Name))
258         then
259            return Self.Data.Values (J).Is_Declared;
260         end if;
261      end loop;
262
263      return False;
264   end Is_Declared;
265
266   -----------------
267   -- Is_Declared --
268   -----------------
269
270   function Is_Declared
271    (Self          : SAX_Attributes'Class;
272     Namespace_URI : League.Strings.Universal_String;
273     Local_Name    : League.Strings.Universal_String)
274       return Boolean is
275   begin
276      for J in 1 .. Self.Data.Length loop
277         if String_Handler.Is_Equal
278             (Self.Data.Values (J).Namespace_URI,
279              League.Strings.Internals.Internal (Namespace_URI))
280           and String_Handler.Is_Equal
281                (Self.Data.Values (J).Local_Name,
282                 League.Strings.Internals.Internal (Local_Name))
283         then
284            return Self.Data.Values (J).Is_Declared;
285         end if;
286      end loop;
287
288      return False;
289   end Is_Declared;
290
291   --------------
292   -- Is_Empty --
293   --------------
294
295   function Is_Empty (Self : SAX_Attributes'Class) return Boolean is
296   begin
297      return Self.Data.Length = 0;
298   end Is_Empty;
299
300   ------------------
301   -- Is_Specified --
302   ------------------
303
304   function Is_Specified
305    (Self  : SAX_Attributes'Class;
306     Index : Positive) return Boolean is
307   begin
308      if Index > Self.Data.Length then
309         raise Constraint_Error;
310      end if;
311
312      return Self.Data.Values (Index).Is_Specified;
313   end Is_Specified;
314
315   ------------------
316   -- Is_Specified --
317   ------------------
318
319   function Is_Specified
320    (Self           : SAX_Attributes'Class;
321     Qualified_Name : League.Strings.Universal_String)
322       return Boolean is
323   begin
324      for J in 1 .. Self.Data.Length loop
325         if String_Handler.Is_Equal
326             (Self.Data.Values (J).Qualified_Name,
327              League.Strings.Internals.Internal (Qualified_Name))
328         then
329            return Self.Data.Values (J).Is_Specified;
330         end if;
331      end loop;
332
333      return False;
334   end Is_Specified;
335
336   ------------------
337   -- Is_Specified --
338   ------------------
339
340   function Is_Specified
341    (Self          : SAX_Attributes'Class;
342     Namespace_URI : League.Strings.Universal_String;
343     Local_Name    : League.Strings.Universal_String)
344       return Boolean is
345   begin
346      for J in 1 .. Self.Data.Length loop
347         if String_Handler.Is_Equal
348             (Self.Data.Values (J).Namespace_URI,
349              League.Strings.Internals.Internal (Namespace_URI))
350           and String_Handler.Is_Equal
351                (Self.Data.Values (J).Local_Name,
352                 League.Strings.Internals.Internal (Local_Name))
353         then
354            return Self.Data.Values (J).Is_Specified;
355         end if;
356      end loop;
357
358      return False;
359   end Is_Specified;
360
361   ------------
362   -- Length --
363   ------------
364
365   function Length (Self : SAX_Attributes'Class) return Natural is
366   begin
367      return Self.Data.Length;
368   end Length;
369
370   ----------------
371   -- Local_Name --
372   ----------------
373
374   function Local_Name
375    (Self  : SAX_Attributes'Class;
376     Index : Positive) return League.Strings.Universal_String is
377   begin
378      if Index > Self.Data.Length then
379         raise Constraint_Error;
380      end if;
381
382      return
383        League.Strings.Internals.Create (Self.Data.Values (Index).Local_Name);
384   end Local_Name;
385
386   -------------------
387   -- Namespace_URI --
388   -------------------
389
390   function Namespace_URI
391    (Self  : SAX_Attributes'Class;
392     Index : Positive) return League.Strings.Universal_String is
393   begin
394      if Index > Self.Data.Length then
395         raise Constraint_Error;
396      end if;
397
398      return
399        League.Strings.Internals.Create
400         (Self.Data.Values (Index).Namespace_URI);
401   end Namespace_URI;
402
403   --------------------
404   -- Qualified_Name --
405   --------------------
406
407   function Qualified_Name
408    (Self  : SAX_Attributes'Class;
409     Index : Positive) return League.Strings.Universal_String is
410   begin
411      if Index > Self.Data.Length then
412         raise Constraint_Error;
413      end if;
414
415      return
416         League.Strings.Internals.Create
417          (Self.Data.Values (Index).Qualified_Name);
418   end Qualified_Name;
419
420   ---------------
421   -- Reference --
422   ---------------
423
424   procedure Reference (Self : Shared_Attributes_Access) is
425   begin
426      if Self /= Shared_Empty'Access then
427         Matreshka.Atomics.Counters.Increment (Self.Counter);
428      end if;
429   end Reference;
430
431   ---------------
432   -- Set_Value --
433   ---------------
434
435   procedure Set_Value
436    (Self           : in out SAX_Attributes'Class;
437     Qualified_Name : League.Strings.Universal_String;
438     Value          : League.Strings.Universal_String)
439   is
440      use type Matreshka.Internals.Strings.Shared_String_Access;
441
442      Shared_Value : constant Matreshka.Internals.Strings.Shared_String_Access
443        := League.Strings.Internals.Internal (Value);
444      Index        : constant Natural := Self.Index (Qualified_Name);
445      CDATA_Name   : constant Universal_String
446        := To_Universal_String ("CDATA");
447
448   begin
449      if Index = 0 then
450         Detach (Self.Data, Self.Data.Length + 1);
451
452         Self.Data.Length := Self.Data.Length + 1;
453         Self.Data.Values (Self.Data.Length) :=
454          (Namespace_URI  => Matreshka.Internals.Strings.Shared_Empty'Access,
455           Local_Name     => Matreshka.Internals.Strings.Shared_Empty'Access,
456           Qualified_Name =>
457             League.Strings.Internals.Internal (Qualified_Name),
458           Value          => League.Strings.Internals.Internal (Value),
459           Value_Type     => League.Strings.Internals.Internal (CDATA_Name),
460           Is_Declared    => False,
461           Is_Specified   => True);
462         Matreshka.Internals.Strings.Reference
463          (Self.Data.Values (Self.Data.Length).Qualified_Name);
464         Matreshka.Internals.Strings.Reference
465          (Self.Data.Values (Self.Data.Length).Value);
466         Matreshka.Internals.Strings.Reference
467          (Self.Data.Values (Self.Data.Length).Value_Type);
468
469      else
470         Detach (Self.Data, Self.Data.Length);
471
472         if Shared_Value /= Self.Data.Values (Index).Value then
473            Matreshka.Internals.Strings.Dereference
474             (Self.Data.Values (Index).Value);
475            Matreshka.Internals.Strings.Reference (Shared_Value);
476            Self.Data.Values (Index).Value := Shared_Value;
477         end if;
478      end if;
479   end Set_Value;
480
481   ---------------
482   -- Set_Value --
483   ---------------
484
485   procedure Set_Value
486    (Self          : in out SAX_Attributes'Class;
487     Namespace_URI : League.Strings.Universal_String;
488     Local_Name    : League.Strings.Universal_String;
489     Value         : League.Strings.Universal_String)
490   is
491      use type Matreshka.Internals.Strings.Shared_String_Access;
492
493      Shared_Value : constant Matreshka.Internals.Strings.Shared_String_Access
494        := League.Strings.Internals.Internal (Value);
495      Index        : constant Natural
496        := Self.Index (Namespace_URI, Local_Name);
497      CDATA_Name   : constant Universal_String
498        := To_Universal_String ("CDATA");
499
500   begin
501      if Index = 0 then
502         Detach (Self.Data, Self.Data.Length + 1);
503
504         Self.Data.Length := Self.Data.Length + 1;
505         Self.Data.Values (Self.Data.Length) :=
506          (Namespace_URI  => League.Strings.Internals.Internal (Namespace_URI),
507           Local_Name     => League.Strings.Internals.Internal (Local_Name),
508           Qualified_Name => Matreshka.Internals.Strings.Shared_Empty'Access,
509           Value          => League.Strings.Internals.Internal (Value),
510           Value_Type     => League.Strings.Internals.Internal (CDATA_Name),
511           Is_Declared    => False,
512           Is_Specified   => True);
513         Matreshka.Internals.Strings.Reference
514          (Self.Data.Values (Self.Data.Length).Namespace_URI);
515         Matreshka.Internals.Strings.Reference
516          (Self.Data.Values (Self.Data.Length).Local_Name);
517         Matreshka.Internals.Strings.Reference
518          (Self.Data.Values (Self.Data.Length).Value);
519         Matreshka.Internals.Strings.Reference
520          (Self.Data.Values (Self.Data.Length).Value_Type);
521
522      else
523         Detach (Self.Data, Self.Data.Length);
524
525         if Shared_Value /= Self.Data.Values (Index).Value then
526            Matreshka.Internals.Strings.Dereference
527             (Self.Data.Values (Index).Value);
528            Matreshka.Internals.Strings.Reference (Shared_Value);
529            Self.Data.Values (Index).Value := Shared_Value;
530         end if;
531      end if;
532   end Set_Value;
533
534   -----------
535   -- Value --
536   -----------
537
538   function Value
539    (Self  : SAX_Attributes'Class;
540     Index : Positive) return League.Strings.Universal_String is
541   begin
542      if Index > Self.Data.Length then
543         raise Constraint_Error;
544      end if;
545
546      return League.Strings.Internals.Create (Self.Data.Values (Index).Value);
547   end Value;
548
549   -----------
550   -- Value --
551   -----------
552
553   function Value
554    (Self           : SAX_Attributes'Class;
555     Qualified_Name : League.Strings.Universal_String)
556       return League.Strings.Universal_String is
557   begin
558      for J in 1 .. Self.Data.Length loop
559         if String_Handler.Is_Equal
560             (Self.Data.Values (J).Qualified_Name,
561              League.Strings.Internals.Internal (Qualified_Name))
562         then
563            return
564              League.Strings.Internals.Create (Self.Data.Values (J).Value);
565         end if;
566      end loop;
567
568      return Empty_Universal_String;
569   end Value;
570
571   -----------
572   -- Value --
573   -----------
574
575   function Value
576    (Self          : SAX_Attributes'Class;
577     Namespace_URI : League.Strings.Universal_String;
578     Local_Name    : League.Strings.Universal_String)
579       return League.Strings.Universal_String is
580   begin
581      for J in 1 .. Self.Data.Length loop
582         if String_Handler.Is_Equal
583             (Self.Data.Values (J).Namespace_URI,
584              League.Strings.Internals.Internal (Namespace_URI))
585           and String_Handler.Is_Equal
586                (Self.Data.Values (J).Local_Name,
587                 League.Strings.Internals.Internal (Local_Name))
588         then
589            return
590              League.Strings.Internals.Create (Self.Data.Values (J).Value);
591         end if;
592      end loop;
593
594      return Empty_Universal_String;
595   end Value;
596
597   ----------------
598   -- Value_Type --
599   ----------------
600
601   function Value_Type
602    (Self  : SAX_Attributes'Class;
603     Index : Positive) return League.Strings.Universal_String is
604   begin
605      if Index > Self.Data.Length then
606         raise Constraint_Error;
607      end if;
608
609      return
610        League.Strings.Internals.Create (Self.Data.Values (Index).Value_Type);
611   end Value_Type;
612
613   ----------------
614   -- Value_Type --
615   ----------------
616
617   function Value_Type
618    (Self           : SAX_Attributes'Class;
619     Qualified_Name : League.Strings.Universal_String)
620       return League.Strings.Universal_String is
621   begin
622      for J in 1 .. Self.Data.Length loop
623         if String_Handler.Is_Equal
624             (Self.Data.Values (J).Qualified_Name,
625              League.Strings.Internals.Internal (Qualified_Name))
626         then
627            return
628              League.Strings.Internals.Create
629               (Self.Data.Values (J).Value_Type);
630         end if;
631      end loop;
632
633      return Empty_Universal_String;
634   end Value_Type;
635
636   ----------------
637   -- Value_Type --
638   ----------------
639
640   function Value_Type
641    (Self          : SAX_Attributes'Class;
642     Namespace_URI : League.Strings.Universal_String;
643     Local_Name    : League.Strings.Universal_String)
644       return League.Strings.Universal_String is
645   begin
646      for J in 1 .. Self.Data.Length loop
647         if String_Handler.Is_Equal
648             (Self.Data.Values (J).Namespace_URI,
649              League.Strings.Internals.Internal (Namespace_URI))
650           and String_Handler.Is_Equal
651                (Self.Data.Values (J).Local_Name,
652                 League.Strings.Internals.Internal (Local_Name))
653         then
654            return
655              League.Strings.Internals.Create
656               (Self.Data.Values (J).Value_Type);
657         end if;
658      end loop;
659
660      return Empty_Universal_String;
661   end Value_Type;
662
663end XML.SAX.Attributes;
664