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