~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty

« back to all changes in this revision

Viewing changes to src/xml/xml-parser.scm

• browse files at revision 12
• compare with another revision
• download diff
• download tarball
• view history from revision 12

Show diffs side-by-side

added

removed

src/xml/xml-parser.scm

1

1

#| -*-Scheme-*-

2

2

 

3

 

$Id: xml-parser.scm,v 1.82 2008/10/26 23:35:24 cph Exp $

4

 

 

5

3

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,

6

4

    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,

7

 

    2006, 2007, 2008 Massachusetts Institute of Technology

 

5

    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology

8

6

 

9

7

This file is part of MIT/GNU Scheme.

10

8

 

390

388

        (if (there-exists? (cdr attrs)

391

389

              (lambda (attr)

392

390

                (xml-name=? (xml-attribute-name attr) name)))

393

 

            (perror p "Attributes with same name" (xml-name-qname name)))))))

 

391

            (perror p "Attributes with same name" (xml-name->symbol name)))))))

394

392

 

395

393

(define (parse-element-content b p name)

396

394

  (let ((vc (parse-content b)))

401

399

          (if (peek-parser-buffer-char b)

402

400

              (perror (get-parser-buffer-pointer b) "Unknown content")

403

401

              (perror p "Unterminated start tag" name)))

404

 

      (if (not (eq? (xml-name-qname (vector-ref ve 0))

405

 

                    (xml-name-qname name)))

 

402

      (if (not (eq? (xml-name->symbol (vector-ref ve 0))

 

403

                    (xml-name->symbol name)))

406

404

          (perror p "Mismatched start tag" (vector-ref ve 0) name))

407

405

      (let ((content (coalesce-strings! (vector->list vc))))

408

406

        (if (null? content)

431

429

 

432

430

;;;; Attribute defaulting

433

431

 

434

 

(define (process-attr-decls qname attrs p)

 

432

(define (process-attr-decls name attrs p)

435

433

  (let ((decl

436

434

         (and (or *standalone?* *internal-dtd?*)

437

435

              (find-matching-item *att-decls*

438

436

                (lambda (decl)

439

 

                  (xml-name=? (xml-!attlist-name decl) qname))))))

 

437

                  (xml-name=? (xml-!attlist-name decl) name))))))

440

438

    (if decl

441

439

        (do ((defns (xml-!attlist-definitions decl) (cdr defns))

442

440

             (attrs attrs (process-attr-defn (car defns) attrs p)))

444

442

        attrs)))

445

443

 

446

444

(define (process-attr-defn defn attrs p)

447

 

  (let ((qname (car defn))

 

445

  (let ((name (car defn))

448

446

        (type (cadr defn))

449

447

        (default (caddr defn)))

450

448

    (let ((attr

451

449

           (find-matching-item attrs

452

450

             (lambda (attr)

453

 

               (xml-name=? (car (xml-attribute-name attr)) qname)))))

 

451

               (xml-name=? (car (xml-attribute-name attr)) name)))))

454

452

      (if attr

455

453

          (let ((av (xml-attribute-value attr)))

456

454

            (if (and (pair? default)

457

455

                     (eq? (car default) '|#FIXED|)

458

456

                     (not (string=? av (cdr default))))

459

 

                (perror (cdar attr) "Incorrect attribute value" qname))

 

457

                (perror (cdar attr) "Incorrect attribute value" name))

460

458

            (if (not (eq? type '|CDATA|))

461

459

                (set-xml-attribute-value! attr (trim-attribute-whitespace av)))

462

460

            attrs)

463

461

          (begin

464

462

            (if (eq? default '|#REQUIRED|)

465

 

                (perror p "Missing required attribute value" qname))

 

463

                (perror p "Missing required attribute value" name))

466

464

            (if (pair? default)

467

 

                (cons (%make-xml-attribute (cons qname p) (cdr default)) attrs)

 

465

                (cons (%make-xml-attribute (cons name p) (cdr default)) attrs)

468

466

                attrs))))))

469

467

 

470

468

;;;; Other markup

537

535

(define parse-unexpanded-name           ;[5]

538

536

  (*parser

539

537

   (with-pointer p

540

 

     (map (lambda (s) (cons (make-xml-qname s) p))

541

 

          (match match-qname)))))

 

538

     (map (lambda (s) (cons (make-xml-name s) p))

 

539

          (match match:xml-name)))))

542

540

 

543

541

(define (simple-name-parser type)

544

542

  (let ((m (string-append "Malformed " type " name")))

545

 

    (*parser (require-success m (map make-xml-qname (match match-ncname))))))

 

543

    (*parser (require-success m (map make-xml-name (match match:xml-name))))))

546

544

 

547

545

(define parse-entity-name (simple-name-parser "entity"))

548

546

(define parse-pi-name (simple-name-parser "processing-instructions"))

549

547

(define parse-notation-name (simple-name-parser "notation"))

550

548

 

551

 

(define match-qname

552

 

  (*matcher

553

 

   (seq match-ncname

554

 

        (? (seq ":" match-ncname)))))

555

 

 

556

 

(define (match-ncname buffer)

557

 

  (and (match-parser-buffer-char-in-alphabet buffer alphabet:ncname-initial)

558

 

       (let loop ()

559

 

         (if (match-parser-buffer-char-in-alphabet buffer

560

 

                                                   alphabet:ncname-subsequent)

561

 

             (loop)

562

 

             #t))))

563

 

 

564

 

(define parse-required-name-token       ;[7]

 

549

(define parse-required-nmtoken          ;[7]

565

550

  (*parser

566

551

   (require-success "Malformed XML name token"

567

 

     (map make-xml-nmtoken (match match-name-token)))))

568

 

 

569

 

(define (match-name-token buffer)

570

 

  (and (match-parser-buffer-char-in-alphabet buffer alphabet:name-subsequent)

571

 

       (let loop ()

572

 

         (if (match-parser-buffer-char-in-alphabet buffer

573

 

                                                   alphabet:name-subsequent)

574

 

             (loop)

575

 

             #t))))

 

552

     (map make-xml-nmtoken (match match:xml-nmtoken)))))

576

553

 

577

554

;;;; Namespaces

578

555

 

583

560

              (let ((uname (xml-attribute-name (car attrs)))

584

561

                    (value (xml-attribute-value (car attrs)))

585

562

                    (tail (loop (cdr attrs))))

586

 

                (let ((qname (car uname))

 

563

                (let ((name (car uname))

587

564

                      (p (cdr uname)))

588

565

                  (let ((forbidden-uri

589

566

                         (lambda ()

590

567

                           (perror p "Forbidden namespace URI" value))))

591

 

                    (cond ((xml-name=? qname 'xmlns)

592

 

                           (string->uri value) ;signals error if not URI

593

 

                           (if (or (string=? value xml-uri-string)

594

 

                                   (string=? value xmlns-uri-string))

595

 

                               (forbidden-uri))

596

 

                           (cons (cons (null-xml-name-prefix) value) tail))

597

 

                          ((xml-name-prefix=? qname 'xmlns)

598

 

                           (if (xml-name=? qname 'xmlns:xmlns)

599

 

                               (perror p "Illegal namespace prefix" qname))

600

 

                           (string->uri value) ;signals error if not URI

601

 

                           (if (if (xml-name=? qname 'xmlns:xml)

 

568

                    (cond ((xml-name=? name 'xmlns)

 

569

                           (let ((uri (string->absolute-uri value)))

 

570

                             (if (or (uri=? value xml-uri)

 

571

                                     (uri=? value xmlns-uri))

 

572

                                 (forbidden-uri))

 

573

                             (cons (cons (null-xml-name-prefix) uri)

 

574

                                   tail)))

 

575

                          ((and (xml-qname? name)

 

576

                                (xml-name-prefix=? name 'xmlns))

 

577

                           (if (xml-name=? name 'xmlns:xmlns)

 

578

                               (perror p "Illegal namespace prefix" name))

 

579

                           (string->uri value) ;signals error if not URI

 

580

                           (if (if (xml-name=? name 'xmlns:xml)

602

581

                                   (not (string=? value xml-uri-string))

603

582

                                   (or (string-null? value)

604

583

                                       (string=? value xml-uri-string)

605

584

                                       (string=? value xmlns-uri-string)))

606

585

                               (forbidden-uri))

607

 

                           (cons (cons (xml-name-local qname) value) tail))

 

586

                           (cons (cons (xml-name-local name) value) tail))

608

587

                          (else tail)))))

609

588

              *prefix-bindings*)))

610

589

  unspecific)

613

592

(define (expand-attribute-name uname) (expand-name uname #t))

614

593

 

615

594

(define (expand-name uname attribute-name?)

616

 

  (let ((qname (car uname))

 

595

  (let ((name (car uname))

617

596

        (p (cdr uname)))

618

 

    (if *in-dtd?*

619

 

        qname

620

 

        (let ((string (lookup-namespace-prefix qname p attribute-name?)))

621

 

          (if (string-null? string)

622

 

              qname

623

 

              (%make-xml-name qname string))))))

 

597

    (if (or *in-dtd?*

 

598

            (not (xml-qname? name)))

 

599

        name

 

600

        (let ((uri (lookup-namespace-prefix name p attribute-name?)))

 

601

          (if (null-xml-namespace-uri? uri)

 

602

              name

 

603

              (%make-xml-name name uri))))))

624

604

 

625

605

(define (lookup-namespace-prefix qname p attribute-name?)

626

606

  (let ((prefix (xml-qname-prefix qname)))

627

607

    (cond ((eq? prefix 'xmlns)

628

 

           xmlns-uri-string)

 

608

           xmlns-uri)

629

609

          ((eq? prefix 'xml)

630

 

           xml-uri-string)

 

610

           xml-uri)

631

611

          ((and attribute-name?

632

612

                (null-xml-name-prefix? prefix))

633

 

           "")

 

613

           (null-xml-namespace-uri))

634

614

          (else

635

615

           (let ((entry (assq prefix *prefix-bindings*)))

636

616

             (if entry

638

618

                 (begin

639

619

                   (if (not (null-xml-name-prefix? prefix))

640

620

                       (perror p "Undeclared XML prefix" prefix))

641

 

                   "")))))))

 

621

                   (null-xml-namespace-uri))))))))

642

622

 

643

623

;;;; Processing instructions

644

624

 

693

673

  (let ((make-ref

694

674

         (lambda (s r p)

695

675

           (let ((n (string->number s r)))

696

 

             (if (not (unicode-code-point? n))

 

676

             (if (not (unicode-scalar-value? n))

697

677

                 (perror p "Invalid code point" n))

698

678

             (let ((char (integer->char n)))

699

679

               (if (not (char-in-alphabet? char alphabet:xml-char))

732

712

         (alt (seq "#"

733

713

                   (alt match-decimal

734

714

                        (seq "x" match-hexadecimal)))

735

 

              match-qname)

 

715

              match:xml-name)

736

716

         ";"))))

737

717

 

738

718

(define parse-entity-reference-name     ;[68]

741

721

     parse-entity-name)))

742

722

 

743

723

(define parse-entity-reference-deferred

744

 

  (*parser (match (seq "&" match-qname ";"))))

 

724

  (*parser (match (seq "&" match:xml-name ";"))))

745

725

 

746

726

(define parse-parameter-entity-reference-name ;[69]

747

727

  (*parser

791

771

                         (lambda (a) (car a))))

792

772

 

793

773

(define parse-declaration-attributes

794

 

  (attribute-list-parser (*parser (map make-xml-qname (match match-qname)))

 

774

  (attribute-list-parser (*parser (map make-xml-name (match match:xml-name)))

795

775

                         (lambda (a) a)))

796

776

 

797

777

(define (attribute-value-parser alphabet parse-reference)

1148

1128

         parse-required-element-name

1149

1129

         S

1150

1130

         ;;[46]

1151

 

         (alt (map make-xml-qname (match "EMPTY"))

1152

 

              (map make-xml-qname (match "ANY"))

 

1131

         (alt (map make-xml-name (match "EMPTY"))

 

1132

              (map make-xml-name (match "ANY"))

1153

1133

              ;;[51]

1154

1134

              (encapsulate vector->list

1155

1135

                (with-pointer p

1199

1179

 

1200

1180

(define parse-!attlist-type             ;[54,57]

1201

1181

  (*parser

1202

 

   (alt (map make-xml-qname

 

1182

   (alt (map make-xml-name

1203

1183

             ;;[55,56]

1204

1184

             (match (alt "CDATA" "IDREFS" "IDREF" "ID"

1205

1185

                         "ENTITY" "ENTITIES" "NMTOKENS" "NMTOKEN")))

1206

1186

        ;;[58]

1207

1187

        (encapsulate vector->list

1208

1188

          (bracket "notation type"

1209

 

              (seq (map make-xml-qname (match "NOTATION"))

 

1189

              (seq (map make-xml-name (match "NOTATION"))

1210

1190

                   S

1211

1191

                   "(")

1212

1192

              ")"

1218

1198

        (encapsulate (lambda (v) (cons 'enumerated (vector->list v)))

1219

1199

          (sbracket "enumerated type" "(" ")"

1220

1200

            S?

1221

 

            parse-required-name-token

1222

 

            (* (seq S? "|" S? parse-required-name-token))

 

1201

            parse-required-nmtoken

 

1202

            (* (seq S? "|" S? parse-required-nmtoken))

1223

1203

            S?)))))

1224

1204

 

1225

1205

(define parse-!attlist-default          ;[60]

• Older »

Loggerhead is a web-based interface for Breezy
Version: 2.0.1