1{ 2 Copyright (c) 2013 by Yury Sidorov and the FPC Development Team 3 4 XML output of a PPU File 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 ****************************************************************************} 21 22unit ppuxml; 23{$mode objfpc}{$H+} 24 25interface 26 27uses 28 SysUtils, Classes, ppuout; 29 30type 31 { TPpuXmlOutput } 32 33 TPpuXmlOutput = class(TPpuOutput) 34 private 35 function XmlStr(const s: string): string; 36 function GetTagName(const n, def: string): string; 37 protected 38 procedure WriteObjectStart(const AName: string; Def: TPpuDef); override; 39 procedure WriteObjectEnd(const AName: string; Def: TPpuDef); override; 40 procedure WriteArrayStart(const AName: string); override; 41 procedure WriteArrayEnd(const AName: string); override; 42 procedure WriteStr(const AName, AValue: string); override; 43 public 44 procedure Init; override; 45 end; 46 47implementation 48 49{ TPpuXmlOutput } 50 51function TPpuXmlOutput.XmlStr(const s: string): string; 52var 53 ws: widestring; 54 ps: PWideChar; 55 pd: PAnsiChar; 56 slen, dlen, dpos: integer; 57 58 procedure _AddChar(c: ansichar); 59 begin 60 if dpos = dlen then begin 61 dlen:=dlen*2; 62 SetLength(Result, dlen); 63 pd:=PAnsiChar(Result) + dpos; 64 end; 65 pd^:=c; 66 Inc(pd); 67 Inc(dpos); 68 end; 69 70 procedure _AddStr(const s: string); 71 var 72 p: PAnsiChar; 73 i: integer; 74 begin 75 p:=PAnsiChar(s); 76 for i:=1 to Length(s) do begin 77 _AddChar(p^); 78 Inc(p); 79 end; 80 end; 81 82var 83 c: widechar; 84begin 85 ws:=UTF8Decode(s); 86 ps:=PWideChar(ws); 87 slen:=Length(ws); 88 dlen:=slen + 2; 89 SetLength(Result, dlen); 90 pd:=PAnsiChar(Result); 91 dpos:=0; 92 while slen > 0 do begin 93 c:=ps^; 94 case c of 95 '<': _AddStr('<'); 96 '>': _AddStr('>'); 97 '&': _AddStr('&'); 98 '''': _AddStr('''); 99 '"': _AddStr('"'); 100 '\': _AddStr('\\'); 101 else 102 if (c > #127) or (byte(c) in [9, 10, 13]) then 103 _AddStr('&#x' + hexStr(word(c), 4) + ';') 104 else 105 if c < #32 then 106 _AddStr('\x' + hexStr(byte(c), 2)) 107 else 108 _AddChar(c); 109 end; 110 Inc(ps); 111 Dec(slen); 112 end; 113 SetLength(Result, dpos); 114end; 115 116function TPpuXmlOutput.GetTagName(const n, def: string): string; 117begin 118 Result:=LowerCase(n); 119 if Result = '' then 120 Result:=def; 121end; 122 123procedure TPpuXmlOutput.WriteStr(const AName, AValue: string); 124begin 125 if AName = 'Type' then 126 exit; 127 WriteLn(Format('<%s>%s</%0:s>', [GetTagName(AName, 'value'), XmlStr(AValue)])); 128end; 129 130procedure TPpuXmlOutput.WriteArrayStart(const AName: string); 131begin 132 if (AName = '') and (Indent = 0) then 133 exit; 134 WriteLn(Format('<%s>', [GetTagName(AName, 'array')])); 135 inherited; 136end; 137 138procedure TPpuXmlOutput.WriteArrayEnd(const AName: string); 139begin 140 if (AName = '') and (Indent = 0) then 141 exit; 142 inherited; 143 WriteLn(Format('</%s>', [GetTagName(AName, 'array')])); 144end; 145 146procedure TPpuXmlOutput.WriteObjectStart(const AName: string; Def: TPpuDef); 147begin 148 if Def = nil then 149 WriteLn(Format('<%s>', [GetTagName(AName, 'object')])) 150 else 151 WriteLn(Format('<%s>', [GetTagName(Def.DefTypeName, 'object')])); 152 inherited; 153end; 154 155procedure TPpuXmlOutput.WriteObjectEnd(const AName: string; Def: TPpuDef); 156begin 157 inherited; 158 if Def = nil then 159 WriteLn(Format('</%s>', [GetTagName(AName, 'object')])) 160 else 161 WriteLn(Format('</%s>', [GetTagName(Def.DefTypeName, 'object')])); 162end; 163 164procedure TPpuXmlOutput.Init; 165begin 166 inherited Init; 167 WriteLn('<?xml version="1.0" encoding="utf-8"?>'); 168end; 169 170end. 171 172