← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/forms/fd2pascal.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/forms/fd2pascal.pp
1
 
Program fd2pascal;
2
 
 
3
 
{ ---------------------------------------------------------------------------
4
 
    Program to convert forms fdesign file to pascal code
5
 
    Copyright (C) 1997  Michael Van Canneyt
6
 
 
7
 
    This program is free software; you can redistribute it and/or modify
8
 
    it under the terms of the GNU General Public License as published by
9
 
    the Free Software Foundation; either version 1, or (at your option)
10
 
    any later version.
11
 
 
12
 
    This program is distributed in the hope that it will be useful,
13
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15
 
    GNU General Public License for more details.
16
 
 
17
 
    You should have received a copy of the GNU General Public License
18
 
    along with this program; if not, write to the Free Software
19
 
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
 
  --------------------------------------------------------------------------- }
21
 
 
22
 
 
23
 
uses
24
 
  baseunix,
25
 
  Unix,
26
 
  unixutil;
27
 
 
28
 
Const RevString = '$Revision: 1.5 $';
29
 
  NrOptions = 4;
30
 
  Options   : Array[0..NrOptions] Of String[20] =
31
 
              ('v','callback','main','altformat','compensate');
32
 
 
33
 
Type
34
 
  { Properties of an object }
35
 
  ContProps=(CPclass,CPtype,CPbox,CPBoxtype,CPColors,CPalignment,CPstyle,CPsize,
36
 
             CPlcol,CPlabel,CPShortcut,CPresize,CPgravity,CPname,CPCallback,
37
 
             CPargument,
38
 
             CPinvalid);
39
 
  { Properties of an object for which defaults must be set }
40
 
  AdjProps=(APClass,APBoxtype,ApColors,APAlignment,APSize,APLcol,APstyle,APgravity);
41
 
  { List of all object classes }
42
 
  ObjClasses=(FL_INVALID,FL_BUTTON, FL_LIGHTBUTTON,FL_ROUNDBUTTON, FL_ROUND3DBUTTON,
43
 
              FL_CHECKBUTTON, FL_BITMAPBUTTON, FL_PIXMAPBUTTON,FL_BITMAP, FL_PIXMAP,
44
 
              FL_BOX, FL_TEXT, FL_MENU, FL_CHART, FL_CHOICE, FL_COUNTER, FL_SLIDER, FL_VALSLIDER, FL_INPUT,
45
 
              FL_BROWSER,FL_DIAL,FL_TIMER,FL_CLOCK, FL_POSITIONER, FL_FREE,
46
 
              FL_XYPLOT,FL_FRAME, FL_LABELFRAME, FL_CANVAS, FL_GLCANVAS,
47
 
              FL_IMAGECANVAS, FL_FOLDER);
48
 
  { Properties in preamble }
49
 
  PreProps=(PPmagic,PPNrforms,PPUnitofMeasure,PPinvalid);
50
 
  { Properties of a form }
51
 
  FormProps=(FPName,FPWidth,FPHeight,FPnumObjs,FPinvalid);
52
 
 
53
 
Const
54
 
  { Names of all object properties }
55
 
  ContPropNames : Array[ContProps] of string[20] =
56
 
            ('class','type','box','boxtype','colors','alignment','style','size',
57
 
             'lcol','label','shortcut','resize','gravity','name','callback',
58
 
             'argument',
59
 
             'invalid');
60
 
  { Names of all object properties which must be checked.}
61
 
  AdjPropsNames : Array[AdjProps] of string[20] =
62
 
          ('class','boxtype','colors','alignment','size','lcol','style','gravity');
63
 
  { Names of all preamble properties }
64
 
  PrePropNames : Array[PreProps] of string[20] =
65
 
            ('Magic','Number of forms','Unit of measure','Invalid');
66
 
  { Names of all form properties }
67
 
  FormPropNames : Array[FormProps] of string[20] =
68
 
            ('Name','Width','Height','Number of Objects','Invalid');
69
 
  { Names of all object classes }
70
 
  FObjClassNames : Array[ObjClasses] of string[20]=
71
 
             ('FL_INVALID','BUTTON', 'LIGHTBUTTON','ROUNDBUTTON', 'ROUND3DBUTTON',
72
 
              'CHECKBUTTON', 'BITMAPBUTTON', 'PIXMAPBUTTON','BITMAP', 'PIXMAP',
73
 
              'BOX', 'TEXT', 'MENU', 'CHART', 'CHOICE', 'COUNTER', 'SLIDER', 'VALSLIDER', 'INPUT',
74
 
              'BROWSER','DIAL','TIMER','CLOCK', 'POSITIONER', 'FREE',
75
 
              'XYPLOT','FRAME', 'LABELFRAME', 'CANVAS', 'GLCANVAS',
76
 
              'IMAGECANVAS', 'FOLDER');
77
 
 
78
 
 { Default properties. If empty a property is ignored.
79
 
   To force setting of a property, put 'FL_FORCE' as a string.
80
 
   Mind : Case sensitive }
81
 
 
82
 
  DefProps : array[ObjClasses,AdjProps] of string[30] =
83
 
             (('FL_INVALID','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
84
 
              ('BUTTON','FL_UP_BOX','FL_COL1 FL_COL1','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
85
 
              ('LIGHTBUTTON','FL_UP_BOX','FL_COL1 FL_YELLOW','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
86
 
              ('ROUNDBUTTON','FL_NO_BOX','FL_MCOL FL_YELLOW','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
87
 
              ('ROUND3DBUTTON','FL_NO_BOX','FL_COL1 FL_BLACK','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
88
 
              ('CHECKBUTTON','FL_NO_BOX','FL_COL1 FL_YELLOW','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
89
 
              ('BITMAPBUTTON','FL_UP_BOX','FL_COL1 FL_BLUE','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
90
 
              ('PIXMAPBUTTON','FL_UP_BOX','FL_COL1 FL_YELLOW','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
91
 
              ('BITMAP','FL_NO_BOX','FL_COL1 FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
92
 
              ('PIXMAP','FL_NO_BOX','FL_COL1 FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
93
 
              ('BOX','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
94
 
              ('TEXT','FL_FLAT_BOX','FL_COL1 FL_MCOL','FL_ALIGN_LEFT','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
95
 
              ('MENU','FL_BORDER_BOX','FL_COL1 FL_MCOL','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
96
 
              ('CHART','FL_BORDER_BOX','FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
97
 
              ('CHOICE','FL_ROUNDED_BOX','FL_COL1 FL_LCOL','FL_ALIGN_LEFT','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
98
 
              ('COUNTER','FL_UP_BOX','FL_COL1 FL_BLUE','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
99
 
              ('SLIDER','FL_DOWN_BOX','FL_COL1 FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
100
 
              ('VALSLIDER','FL_DOWN_BOX','FL_COL1 FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
101
 
              ('INPUT','FL_DOWN_BOX','FL_COL1 FL_MCOL','FL_ALIGN_LEFT','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
102
 
              ('BROWSER','FL_DOWN_BOX','FL_COL1 FL_YELLOW','FL_ALIGN_BOTTOM','FL_SMALL_FONT','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
103
 
              ('DIAL','FL_FLAT_BOX','FL_COL1 FL_RIGHT_BCOL','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
104
 
              ('TIMER','FL_DOWN_BOX','FL_COL1 FL_RED','FL_ALIGN_CENTER','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
105
 
              ('CLOCK','FL_UP_BOX','FL_INACTIVE_COL FL_BOTTOM_BCOL','FL_ALIGN_BOTTOM','','FL_BLACK','FL_NORMAL_STYLE','FL_FORCE'),
106
 
              ('POSITIONER','FL_DOWN_BOX','FL_COL1 FL_RED','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
107
 
              ('FREE','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
108
 
              ('XYPLOT','FL_FLAT_BOX','FL_COL1','FL_ALIGN_BOTTOM','','FL_LCOL','FL_NORMAL_STYLE','FL_FORCE'),
109
 
              ('FRAME','','FL_BLACK FL_COL1','','','FL_BLACK','FL_NORMAL_STYLE','FL_FORCE'),
110
 
              ('LABELFRAME','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
111
 
              ('CANVAS','FL_NO_BOX','','FL_ALIGN_TOP','','','FL_NORMAL_STYLE','FL_FORCE'),
112
 
              ('GLCANVAS','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
113
 
              ('IMAGECANVAS','','','','','','FL_NORMAL_STYLE','FL_FORCE'),
114
 
              ('FOLDER','','','','','','FL_NORMAL_STYLE','FL_FORCE'));
115
 
 
116
 
Type
117
 
  { object data type }
118
 
  PControl = ^TControl;
119
 
  TControl = Record
120
 
    Props : array[ContProps] of string;
121
 
    NextControl : PControl;
122
 
    end;
123
 
 
124
 
  { Form data type}
125
 
  PFormRec = ^TFormRec;
126
 
  TFormRec = Record
127
 
    Name : String;
128
 
    Width,Height : String[5];
129
 
    Controls : PControl;
130
 
    NextForm : PFormRec;
131
 
    end;
132
 
  { Callback data type }
133
 
  PCBrec = ^TCBrec;
134
 
  TCBrec = record
135
 
    name : string;
136
 
    next : PCBrec;
137
 
    end;
138
 
  { Property emitting procedures }
139
 
  EmitProp = Procedure (Data : PControl;ObjClass : ObjClasses);
140
 
 
141
 
Var
142
 
  OptionsSet : Array[1..NrOptions] Of Boolean;
143
 
  FileName : String;
144
 
  Infile,outfile : Text;
145
 
  LineNr : Longint;
146
 
  NrForms,NrControls : Longint;
147
 
  FormRoot : PFormRec;
148
 
  cbroot : pcbrec;
149
 
  { Default properties emitters }
150
 
  EmitProcs : array [AdjProps] of EmitProp;
151
 
  { Class specific property emitters. Nil pointers are ignored.}
152
 
  ClassEmitters : Array[ObjClasses] of EmitProp;
153
 
 
154
 
{ ------------------------------------------------------------------------
155
 
  Utilities Code
156
 
  ------------------------------------------------------------------------ }
157
 
 
158
 
 
159
 
Function IntTostr (s : Longint) : String;
160
 
 
161
 
var temp : String;
162
 
 
163
 
begin
164
 
  str(s,temp);
165
 
  IntToStr:=Temp;
166
 
end;
167
 
 
168
 
 
169
 
Procedure EmitError (Const s : String);
170
 
 
171
 
begin
172
 
  writeln (stderr,'Error: ',s);
173
 
  flush(stderr)
174
 
end;
175
 
 
176
 
Procedure EmitLineError (Const s : string);
177
 
 
178
 
begin
179
 
  EmitError('Line '+IntToStr(LineNr)+': '+s)
180
 
end;
181
 
 
182
 
 
183
 
{ ------------------------------------------------------------------------
184
 
  Option handling Code
185
 
  ------------------------------------------------------------------------ }
186
 
 
187
 
 
188
 
Procedure DoOptions;
189
 
 
190
 
Var i,j,k : byte;
191
 
    os : string;
192
 
 
193
 
Procedure ShowVersion;
194
 
 
195
 
begin
196
 
  Writeln ('fd2pascal : ',RevString);
197
 
  Halt(0);
198
 
end;
199
 
 
200
 
Procedure ShowUsage;
201
 
 
202
 
begin
203
 
  Writeln ('fd2pascal : usage :');
204
 
  writeln (' fd2pascal [options] filename');
205
 
  writeln (' Where [options] may be zero or more of :');
206
 
  writeln ('  -compensate    Emit size-compensation code.');
207
 
  writeln ('  -altformat     Emit code in alternate format.');
208
 
  writeln ('  -main          Emit program instead of unit.');
209
 
  writeln ('  -callback      Emit callback stubs.');
210
 
  writeln;
211
 
  halt(0);
212
 
end;
213
 
 
214
 
begin
215
 
  if paramcount=0 then
216
 
     ShowUsage;
217
 
  FileName:='';
218
 
  for i:=1 to paramcount do
219
 
    begin
220
 
    if paramstr(i)[1]<>'-' then
221
 
      If FileName<>'' then
222
 
        EmitError('Only one filename supported. Ignoring :'+paramstr(i))
223
 
      else
224
 
        Filename:=Paramstr(i)
225
 
    else
226
 
      begin
227
 
      os:=copy(paramstr(i),2,length(paramstr(i))-1);
228
 
      k:=NrOptions+1;
229
 
      for j:=0 to NrOptions do
230
 
        if os=options[j] then k:=j;
231
 
      if k=NrOptions+1 then
232
 
        EmitError('Option not recognised : '+paramstr(i))
233
 
      else
234
 
        if k=0 then ShowVersion else OptionsSet[k]:=True;
235
 
      end
236
 
    end; {for}
237
 
  if FileName='' then
238
 
    begin
239
 
    EmitError('No filename supplied. Exiting.');
240
 
    halt(1);
241
 
    end;
242
 
end;
243
 
 
244
 
{ ------------------------------------------------------------------------
245
 
  Code for reading the input file.
246
 
  ------------------------------------------------------------------------ }
247
 
 
248
 
 
249
 
Procedure OpenFile;
250
 
begin
251
 
  if pos('.fd',FileName)=0 then
252
 
    FileName:=FileName+'.fd';
253
 
  assign(infile,Filename);
254
 
{$i-}
255
 
  reset (infile);
256
 
{$i+}
257
 
  if ioresult<>0 then
258
 
    begin
259
 
    EmitError('Can''t open : '+filename);
260
 
    halt(1);
261
 
    end;
262
 
  LineNr:=0;
263
 
end;
264
 
 
265
 
Procedure CloseFile;
266
 
 
267
 
begin
268
 
  Close(infile);
269
 
end;
270
 
 
271
 
Procedure GetLine(Var S : String);
272
 
 
273
 
begin
274
 
  inc(LineNr);
275
 
  Readln(infile,s);
276
 
{$ifdef debug}
277
 
  writeln ('Reading line : ',linenr)
278
 
{$endif}
279
 
end;
280
 
 
281
 
Procedure ProcessPreAmbleLine (Const s: String);
282
 
 
283
 
var key,value : string;
284
 
    ppos : Longint;
285
 
    i,k : PreProps;
286
 
    code : Word;
287
 
 
288
 
begin
289
 
  if s='' then exit;
290
 
  ppos:=pos(':',s);
291
 
  if ppos=0 then
292
 
    exit;
293
 
  Key:=Copy(s,1,ppos-1);
294
 
  Value:=Copy(s,ppos+2,length(s)-ppos-1);
295
 
  k:=PPinvalid;
296
 
  for i:=PPmagic to PPinvalid do
297
 
    if key=PrePropNames[i] then k:=i;
298
 
  if k=PPinvalid then
299
 
    EmitLineError('Unknown keyword : '+Key)
300
 
  else
301
 
    Case K of
302
 
      PPMagic,
303
 
      PPunitofmeasure: ;
304
 
      PPnrforms: begin
305
 
               val(value,NrForms,code);
306
 
               if code<>0 then EmitLineError('Invalid number of forms');
307
 
               end;
308
 
    end;
309
 
end;
310
 
 
311
 
{ ------------------------------------------------------------------------
312
 
  Code for reading preamble.
313
 
  ------------------------------------------------------------------------ }
314
 
 
315
 
 
316
 
Procedure DoPreamble;
317
 
 
318
 
var line : String;
319
 
 
320
 
begin
321
 
{$ifdef debug}
322
 
  writeln ('Starting preamble');
323
 
{$endif}
324
 
  Getline (line);
325
 
  while pos('= FORM =',line)=0 do
326
 
    begin
327
 
    ProcessPreAmbleLine(line);
328
 
    GetLine(Line)
329
 
    end;
330
 
end;
331
 
 
332
 
{ ------------------------------------------------------------------------
333
 
  Code for reading 1 object.
334
 
  ------------------------------------------------------------------------ }
335
 
 
336
 
 
337
 
Procedure ProcessControlLine (PC : PControl; const S : String);
338
 
 
339
 
Var Key,Value : String;
340
 
    i,k : ContProps;
341
 
    ppos : word;
342
 
 
343
 
begin
344
 
  if s='' then exit;
345
 
  ppos:=pos(':',s);
346
 
  if ppos=0 then
347
 
    exit;
348
 
  Key:=Copy(s,1,ppos-1);
349
 
  Value:=Copy(s,ppos+2,length(s)-ppos-1);
350
 
  K:=CPInvalid;
351
 
  For i:=CPclass to CPInvalid do
352
 
    if ContPropNames[i]=Key then k:=i;
353
 
  if K=CPinvalid then
354
 
     begin
355
 
     EmitLineError('Unknown keyword'+key);
356
 
     exit
357
 
     end;
358
 
  PC^.props[k]:=value;
359
 
end;
360
 
 
361
 
Procedure ProcessControl (PC : PControl);
362
 
 
363
 
var line : String;
364
 
 
365
 
begin
366
 
{$ifdef debug}
367
 
  Writeln ('Starting Control');
368
 
{$endif}
369
 
  Getline(Line);
370
 
  while Line<>'' do
371
 
    begin
372
 
    ProcessControlLine (PC,line);
373
 
    Getline(Line);
374
 
    end;
375
 
  Getline(Line)
376
 
end;
377
 
 
378
 
{ ------------------------------------------------------------------------
379
 
  Code for reading 1 form.
380
 
  ------------------------------------------------------------------------ }
381
 
 
382
 
Procedure ProcessFormLine (PF : PFormRec; const S : String);
383
 
 
384
 
Var Key,Value : String;
385
 
    i,k : FormProps;
386
 
    ppos,code : word;
387
 
 
388
 
begin
389
 
  if s='' then exit;
390
 
  ppos:=pos(':',s);
391
 
  if ppos=0 then
392
 
    exit;
393
 
  Key:=Copy(s,1,ppos-1);
394
 
  Value:=Copy(s,ppos+2,length(s)-ppos-1);
395
 
  K:=FPInvalid;
396
 
  For i:=FPName to FPInvalid do
397
 
    if FormPropNames[i]=Key then k:=i;
398
 
  if K=FPinvalid then
399
 
     begin
400
 
     EmitLineError('Unknown keyword'+key);
401
 
     exit
402
 
     end;
403
 
  case k of
404
 
    FPname    : PF^.name:=value;
405
 
    FPWidth   : PF^.width:=value;
406
 
    FPHeight  : PF^.height:=value;
407
 
    FPNumObjs : begin
408
 
                val(value,Nrcontrols,code);
409
 
                If Code<>0 then EmitLineError('Invalid number of objects : '+value)
410
 
                end;
411
 
    end;
412
 
end;
413
 
 
414
 
Procedure ProcessForm (PF : PFormRec);
415
 
 
416
 
Var line : String;
417
 
    CurrentControl : PControl;
418
 
    I : Integer;
419
 
 
420
 
begin
421
 
{$ifdef debug}
422
 
  writeln('Starting form');
423
 
{$endif}
424
 
  NrControls:=0;
425
 
  with PF^ do
426
 
    begin
427
 
    name:='';
428
 
    Width:='';
429
 
    Height:='';
430
 
    Controls:=nil;
431
 
    GetLine(Line);
432
 
    while line<>'' do
433
 
      begin
434
 
      ProcessFormLine(PF,Line);
435
 
      GetLine(Line);
436
 
      end;
437
 
    Getline(Line);
438
 
    If NrControls=0 then
439
 
      Controls:=nil
440
 
    else
441
 
      begin
442
 
      New (Controls);
443
 
      CurrentControl:=Controls;
444
 
      for i:=1 to nrcontrols do
445
 
        begin
446
 
        ProcessControl(CurrentControl);
447
 
        if i<NrControls then
448
 
          New(CurrentControl^.NextControl)
449
 
        else
450
 
          CurrentControl^.NextControl:=nil;
451
 
        CurrentControl:=CurrentControl^.NextControl
452
 
        end; { for }
453
 
      end; { Else }
454
 
    end; { With }
455
 
end;
456
 
 
457
 
{ ------------------------------------------------------------------------
458
 
  Code for reading the forms.
459
 
  ------------------------------------------------------------------------ }
460
 
 
461
 
 
462
 
Procedure DoForms;
463
 
 
464
 
Var
465
 
    i : Longint;
466
 
    CurrentForm: PformRec;
467
 
 
468
 
begin
469
 
  FormRoot:=Nil;
470
 
  if NrForms=0 then exit;
471
 
  new(FormRoot);
472
 
  Currentform:=FormRoot;
473
 
  for i:=1 to nrforms do
474
 
     begin
475
 
     ProcessForm (CurrentForm);
476
 
     If i=nrforms then
477
 
       Currentform^.NextForm:=nil
478
 
     else
479
 
       New(CurrentForm^.NextForm);
480
 
     CurrentForm:=CurrentForm^.NextForm;
481
 
     end;
482
 
end;
483
 
 
484
 
{ ------------------------------------------------------------------------
485
 
  Code for reading the postamble.
486
 
  ------------------------------------------------------------------------ }
487
 
 
488
 
 
489
 
Procedure DoPostamble;
490
 
 
491
 
begin
492
 
end;
493
 
 
494
 
{ ------------------------------------------------------------------------
495
 
  Code for writing the output file.
496
 
  ------------------------------------------------------------------------ }
497
 
 
498
 
Procedure OpenOutFile;
499
 
 
500
 
var info : stat;
501
 
 
502
 
begin
503
 
  FileName:=Copy(Filename,1,Length(Filename)-3)+'.pp';
504
 
  if fpstat(FileName,info)<>-1 Then
505
 
    begin
506
 
    { File exists, move to .bak}
507
 
      fplink (FileName,FileName+'.bak');
508
 
      fpunlink(FileName);
509
 
    end;
510
 
 
511
 
  assign(outfile,filename);
512
 
{$i-}
513
 
  rewrite(outfile);
514
 
{$i+}
515
 
  if ioresult<>0 then
516
 
    begin
517
 
    EmitError('Couldn''t open output file : '+filename);
518
 
    halt(1)
519
 
    end;
520
 
end;
521
 
 
522
 
Procedure CloseOutFile;
523
 
 
524
 
begin
525
 
 Close(OutFile);
526
 
end;
527
 
 
528
 
{ ------------------------------------------------------------------------
529
 
  Code to emit Header/variable/type declarations
530
 
  ------------------------------------------------------------------------ }
531
 
 
532
 
 
533
 
Procedure EmitType (fp : Pformrec);
534
 
 
535
 
var cp : PControl;
536
 
 
537
 
begin
538
 
  writeln (OutFile,'  TFD_',fp^.name,' = record');
539
 
  writeln (OutFile,'    ',fp^.name,' : PFL_FORM;');
540
 
  writeln (OutFile,'    vdata : Pointer;');
541
 
  writeln (OutFile,'    ldata : Longint;');
542
 
  cp:=fp^.controls;
543
 
  {Skip first control, is formbackground }
544
 
  if cp<>nil then cp:=cp^.nextcontrol;
545
 
  while cp<>nil do
546
 
    begin
547
 
    if cp^.props[CPclass]<>'FL_END_GROUP' then
548
 
      begin
549
 
      write (Outfile,'    ',cp^.props[CPname]);
550
 
      if cp^.nextcontrol<>nil then
551
 
        writeln (OutFile,',')
552
 
      else
553
 
        writeln (OutFile,' : PFL_OBJECT;');
554
 
      end;
555
 
    cp:=cp^.nextcontrol;
556
 
    end;
557
 
  writeln (OutFile,'    end;');
558
 
  writeln (OutFile,'  PFD_',fp^.name,' = ^TFD_',fp^.name,';');
559
 
  writeln (OutFile);
560
 
end;
561
 
 
562
 
Procedure EmitVar (fp : Pformrec);
563
 
 
564
 
var cp : PControl;
565
 
 
566
 
begin
567
 
  writeln (OutFile,'  ',fp^.name,' : PFL_FORM;');
568
 
  cp:=fp^.controls;
569
 
  {Skip first control, is formbackground }
570
 
  if cp<>nil then cp:=cp^.nextcontrol;
571
 
  while cp<>nil do
572
 
    begin
573
 
    if cp^.props[CPclass]<>'FL_END_GROUP' then
574
 
      begin
575
 
      write (Outfile,'  ',cp^.props[CPname]);
576
 
      if cp^.nextcontrol<>nil then
577
 
        writeln (OutFile,',')
578
 
      else
579
 
        writeln (OutFile,' : PFL_OBJECT;');
580
 
      end;
581
 
    cp:=cp^.nextcontrol;
582
 
    end;
583
 
  writeln (OutFile);
584
 
end;
585
 
 
586
 
Procedure EmitHeader;
587
 
 
588
 
var fp : PFormRec;
589
 
 
590
 
begin
591
 
  if OptionsSet[2] then
592
 
    write   (OutFile,'Program ')
593
 
  else
594
 
    write   (OutFile,'Unit ');
595
 
  writeln (OutFile,basename(filename,'.pp'),';');
596
 
  writeln (OutFile);
597
 
  writeln (OutFile,'{ Form definition file generated by fd2pascal }');
598
 
  writeln (Outfile);
599
 
  if not OptionsSet[2] then
600
 
     begin
601
 
     writeln (OutFile,'Interface');
602
 
     writeln (OutFile);
603
 
     end;
604
 
  writeln (OutFile,'Uses forms;');
605
 
  writeln (OutFile);
606
 
  writeln (OutFile,'  { Variable / Type definitions. }');
607
 
  if Optionsset[3] then
608
 
    writeln (OutFile,'Var')
609
 
  else
610
 
    writeln (OutFile,'Type');
611
 
  fp:=FormRoot;
612
 
  While fp<>nil do
613
 
    begin
614
 
    if not optionsset[3] then
615
 
      EmitType(fp) { Emit Type definitions }
616
 
    else
617
 
      EmitVar(fp); { Emit Variable declaration}
618
 
    fp:=fp^.nextform;
619
 
    end;
620
 
  if not optionsset[2] then
621
 
    begin
622
 
    { No program, we must emit interface stuff }
623
 
    if not (optionsset[3]) then
624
 
      begin
625
 
      { Emit normal interface declarations
626
 
        -> functions }
627
 
      fp:=formroot;
628
 
      while fp<>nil do
629
 
        begin
630
 
        with fp^ do
631
 
          writeln (OutFile,'Function create_form_',name,' : PFD_',name,';');
632
 
        fp:=fp^.nextform;
633
 
        end;
634
 
      end
635
 
    else
636
 
      begin
637
 
      { Emit alternate interface declaration
638
 
        -> 1 function to create all forms.}
639
 
      writeln (OutFile,'Procedure Create_The_Forms;');
640
 
      end;
641
 
    writeln (OutFile);
642
 
    writeln (OutFile,'Implementation');
643
 
    end
644
 
  else
645
 
    begin
646
 
    { We must make a program. }
647
 
    if not(optionsset[3]) then
648
 
      begin
649
 
      { Normal format, so we need to emit variables for the forms.}
650
 
      writeln (OutFile,'Var');
651
 
      fp:=formroot;
652
 
      while fp<>nil do
653
 
        begin
654
 
        writeln (OutFile,'  ',fp^.name,' : PFD_',fp^.name,';');
655
 
        fp:=fp^.nextform;
656
 
        end;
657
 
      writeln (OutFile);
658
 
      end;
659
 
    end;
660
 
  writeln (OutFile);
661
 
end;
662
 
 
663
 
{ ------------------------------------------------------------------------
664
 
  Code to emit footer/main program
665
 
  ------------------------------------------------------------------------ }
666
 
 
667
 
 
668
 
Procedure EmitCreateforms;
669
 
 
670
 
var fp : PFormRec;
671
 
 
672
 
begin
673
 
  writeln (OutFile,'Procedure Create_The_Forms;');
674
 
  writeln (OutFile);
675
 
  writeln (OutFile,'begin');
676
 
  fp:=FormRoot;
677
 
  while fp<>nil do
678
 
    begin
679
 
    writeln(OutFile,'create_form_',fp^.name,';');
680
 
    fp:=fp^.nextform;
681
 
    end;
682
 
  writeln (outFile,'End;');
683
 
  writeln (OutFile);
684
 
end;
685
 
 
686
 
Procedure EmitAlternateMain;
687
 
begin
688
 
  { Alternate format, we just call creatallforms to create all forms}
689
 
  writeln (OutFile,'Create_The_Forms;');
690
 
  writeln (OutFile,'  fl_show_form(',formroot^.name,
691
 
                   ',FL_PLACE_CENTER,FL_FULLBORDER,''',
692
 
                   FormRoot^.name,''');');
693
 
end;
694
 
 
695
 
Procedure EmitMain;
696
 
 
697
 
var fp : PFormRec;
698
 
 
699
 
begin
700
 
  { variables are emitted in the header }
701
 
  fp:=formroot;
702
 
  { Create all forms }
703
 
  while fp<>nil do
704
 
    begin
705
 
    writeln (OutFile,'  ',fp^.name,' :=Create_Form_',fp^.name,';');
706
 
    fp:=fp^.nextform;
707
 
    end;
708
 
  { Show the first form }
709
 
  writeln (OutFile,'  fl_show_form(',formroot^.name,'^.',Formroot^.name,
710
 
                   ',FL_PLACE_CENTER,FL_FULLBORDER,''',
711
 
                   FormRoot^.name,''');');
712
 
end;
713
 
 
714
 
Procedure EmitFooter;
715
 
begin
716
 
  if OptionsSet[3] then {Alternate format.}
717
 
     EmitCreateForms;
718
 
  if Optionsset[2] then
719
 
    begin
720
 
    {Emit Main Program}
721
 
    writeln (OutFile);
722
 
    writeln (OutFile,'Begin');
723
 
    writeln (OutFile,'  fl_initialize (@argc,argv,''',
724
 
                     basename(Filename,'.pp'),''',nil,0);');
725
 
    if Not(OptionsSet[3]) then
726
 
      EmitMain
727
 
    else
728
 
      EmitAlternateMain;
729
 
    writeln (OutFile,'  fl_do_forms;');
730
 
    end
731
 
  else
732
 
    writeln (OutFile,'begin');
733
 
  writeln (OutFile,'end.')
734
 
end;
735
 
 
736
 
 
737
 
 
738
 
 
739
 
{ ------------------------------------------------------------------------
740
 
  Code to emit properties
741
 
  ------------------------------------------------------------------------ }
742
 
 
743
 
 
744
 
Function EmitString(S : string) : String;
745
 
 
746
 
var temp : String;
747
 
    i : longint;
748
 
 
749
 
begin
750
 
  temp:='''';
751
 
  for i:=1 to length(s) do
752
 
    if s[i]<>'''' then temp:=temp+s[i] else temp:=temp+'''''';
753
 
  Temp:=temp+'''';
754
 
  EmitString:=temp;
755
 
end;
756
 
 
757
 
Procedure EmitBoxtype (cp : PControl;ObjClass : ObjClasses);
758
 
 
759
 
begin
760
 
{$ifdef debug}
761
 
  writeln ('EmitBoxType called with args:');
762
 
  writeln (cp^.props[cpboxtype]);
763
 
  writeln (defprops[objclass,APboxtype]);
764
 
  writeln ('for object : ',defprops[objclass,apclass]);
765
 
  writeln ('With object : ',cp^.props[cpclass]);
766
 
{$endif}
767
 
  if cp^.props[cpboxtype]<>defprops[objclass,APboxtype] then
768
 
    writeln (OutFile,'    fl_set_object_boxtype(obj,',
769
 
                    cp^.props[cpboxtype],');')
770
 
end;
771
 
 
772
 
Procedure EmitColors (cp : PControl;ObjClass : ObjClasses);
773
 
 
774
 
var temp : string;
775
 
 
776
 
begin
777
 
  if cp^.props[cpcolors]<>defprops[objclass,APcolors] then
778
 
    begin
779
 
    temp:=cp^.props[cpcolors];
780
 
    if pos(' ',temp)=0 then exit;
781
 
    temp[pos(' ',temp)]:=',';
782
 
    writeln (OutFile,'    fl_set_object_color(obj,',temp,');');
783
 
    end;
784
 
end;
785
 
 
786
 
Procedure EmitAlignment (cp : PControl;ObjClass : ObjClasses);
787
 
 
788
 
begin
789
 
 if cp^.props[cpalignment]<>defprops[objclass,APalignment] then
790
 
    writeln (OutFile,'    fl_set_object_alignment(obj,',
791
 
                     cp^.props[cpalignment],');');
792
 
end;
793
 
 
794
 
Procedure EmitLcol (cp : PControl;ObjClass : ObjClasses);
795
 
 
796
 
begin
797
 
 if cp^.props[cplcol]<>defprops[objclass,APlcol] then
798
 
    writeln (OutFile,'    fl_set_object_lcol(obj,',
799
 
                     cp^.props[cplcol],');');
800
 
end;
801
 
 
802
 
 
803
 
Procedure EmitSize (cp : PControl;ObjClass : ObjClasses);
804
 
 
805
 
begin
806
 
 if cp^.props[cpsize]<>defprops[objclass,APsize] then
807
 
    writeln (OutFile,'    fl_set_object_lsize(obj,',
808
 
                     cp^.props[cpsize],');');
809
 
end;
810
 
 
811
 
Procedure EmitStyle (cp : PControl;ObjClass : ObjClasses);
812
 
 
813
 
begin
814
 
 if cp^.props[cpstyle]<>defprops[objclass,APstyle] then
815
 
    writeln (OutFile,'    fl_set_object_lstyle(obj,',
816
 
                     cp^.props[cpstyle],');');
817
 
end;
818
 
 
819
 
Procedure EmitGravity (cp : PControl;ObjClass : ObjClasses);
820
 
 
821
 
var temp: string;
822
 
 
823
 
begin
824
 
 if cp^.props[cpstyle]<>'FL_NoGravity FL_NoGravity' then
825
 
    begin
826
 
    temp:=cp^.props[cpstyle];
827
 
    if pos(' ',temp)=0 then exit;
828
 
    temp[pos(' ',temp)]:=',';
829
 
    writeln (OutFile,'    fl_set_object_gravity(obj,',
830
 
                     temp,');');
831
 
    end;
832
 
end;
833
 
 
834
 
 
835
 
Procedure EmitProperties (Cp : PControl; Objclass : ObjClasses);
836
 
 
837
 
Var i : AdjProps;
838
 
 
839
 
begin
840
 
  for i:=APboxtype to APgravity do
841
 
    if DefProps[ObjClass,i]<>'' then
842
 
       EmitProcs[i](cp,objclass);
843
 
end;
844
 
 
845
 
{ ------------------------------------------------------------------------
846
 
  Code to emit objects
847
 
  ------------------------------------------------------------------------ }
848
 
 
849
 
Procedure EmitObject(cp : PControl);
850
 
 
851
 
var temp : string;
852
 
    I : Longint;
853
 
    j,k : ObjClasses;
854
 
 
855
 
begin
856
 
with cp^ do
857
 
  begin
858
 
  temp:=lowercase(props[CPclass]);
859
 
  delete(temp,1,3);
860
 
  if temp='begin_group' then
861
 
    begin
862
 
    writeln (OutFile);
863
 
    write (OutFile,'  ');
864
 
    if not (Optionsset[3]) then Write (OutFile,'fdui^.');
865
 
    writeln (OutFile,props[cpname],':=fl_bgn_group;');
866
 
    exit;
867
 
    end
868
 
  else if temp='end_group' then
869
 
    begin
870
 
    writeln (OutFile,'  fl_end_group;');
871
 
    writeln (OutFile);
872
 
    exit;
873
 
    end;
874
 
  { Normal object. Emit creation code. }
875
 
  write (OutFile,'  obj:=fl_add_',temp,' (FL_',props[Cptype],',');
876
 
  temp:=props[cpbox];
877
 
  for i:=1 to 3 do
878
 
    begin
879
 
    write (OutFile,copy(temp,1,pos(' ',temp)-1),',');
880
 
    delete (temp,1,pos(' ',temp));
881
 
  end;
882
 
  writeln (OutFile,temp,',',EmitString(props[cplabel]),');');
883
 
  { Emit Callback code if needed }
884
 
  if props[cpcallback]<>'' then
885
 
    begin
886
 
    write (OutFile,'    fl_set_object_callback(obj,PFL_CALLBACKPTR(@');
887
 
    write (OutFile,props[CPcallback],'),');
888
 
    if props[CPargument]<>'' then
889
 
       writeln (OutFile,props[CPargument],');')
890
 
    else
891
 
       writeln (OutFile,'0);');
892
 
    end;
893
 
  { If known object, start emitting properties }
894
 
  temp:=props[CPclass];
895
 
  delete(temp,1,3);
896
 
  k:=FL_INVALID;
897
 
  for j:=FL_BUTTON to FL_FOLDER do
898
 
    if temp=DefProps[j,apclass] then k:=j;
899
 
  if k<>FL_INVALID then
900
 
     begin
901
 
     { Emit defaults }
902
 
     EmitProperties (cp,k);
903
 
     { If A class-specific emitter exists, call it.}
904
 
     if Assigned(ClassEmitters[k]) then
905
 
       ClassEmitters[k] (cp,k);
906
 
     end;
907
 
  { Assign to needed object. }
908
 
  if Optionsset[3] then
909
 
    Writeln (OutFile,'  ',props[cpname],':=obj;')
910
 
  else
911
 
    Writeln (OutFile,'  fdui^.',props[cpname],':=obj;');
912
 
  end;
913
 
end;
914
 
 
915
 
{ ------------------------------------------------------------------------
916
 
  Code to emit forms
917
 
  ------------------------------------------------------------------------ }
918
 
 
919
 
Procedure EmitForm(fp : PFormRec);
920
 
 
921
 
Var
922
 
cp : PControl;
923
 
 
924
 
begin
925
 
with fp^ do
926
 
  begin
927
 
  if Optionsset[3] then
928
 
    begin
929
 
    writeln (OutFile,'Procedure create_form_',name,';');
930
 
    writeln (OutFile);
931
 
    writeln (OutFile,'Var obj : PFL_OBJECT;');
932
 
    writeln (OutFile);
933
 
    writeln (OutFile,'Begin');
934
 
    writeln (OutFile,'  If ',name,'<>nil then exit;');
935
 
    write   (OutFile,'  ',name);
936
 
    end
937
 
  else
938
 
    begin
939
 
    writeln (OutFile,'Function create_form_',name,' : PFD_',name,';');
940
 
    writeln (OutFile);
941
 
    writeln (OutFile,'Var obj : PFL_OBJECT;');
942
 
    writeln (OutFile,'    fdui : PFD_',name,';');
943
 
    writeln (OutFile);
944
 
    writeln (OutFile,'Begin');
945
 
    writeln (OutFile,'  New(fdui);');
946
 
    write (OutFile,'  fdui^.',name);
947
 
    end;
948
 
  writeln (OutFile,':=fl_bgn_form(FL_NO_BOX,'
949
 
                                                  ,width,','
950
 
                                                  ,height,');');
951
 
  cp:=controls;
952
 
  writeln (OutFile,'  obj:=fl_add_box(',cp^.props[CPboxtype],',0,0,',
953
 
                                      width,',',
954
 
                                      height,',',
955
 
                                      EmitString (cp^.props[CPname]),');');
956
 
  cp:=cp^.nextcontrol;
957
 
  { Emit all objects }
958
 
  while cp<>nil do
959
 
    begin
960
 
    EmitObject(cp);
961
 
    cp:=cp^.nextcontrol;
962
 
    end;
963
 
  writeln (OutFile,'  fl_end_form;');
964
 
  if Optionsset[4] then
965
 
    begin
966
 
    { Emit Compensation code }
967
 
    write (OutFile,'  fl_adjust_form_size(');
968
 
    if not(OptionsSet[3]) then write (OutFile,'fdui^.');
969
 
    writeln(OutFile,fp^.name,');');
970
 
    end;
971
 
  if not(OptionsSet[3]) then
972
 
    begin
973
 
    writeln (OutFile,'  fdui^.',fp^.name,'^.fdui:=fdui;');
974
 
    writeln (OutFile,'  create_form_',fp^.name,':=fdui;');
975
 
    end;
976
 
  writeln (OutFile,'end;');
977
 
  writeln (OutFile);
978
 
  end;
979
 
end;
980
 
 
981
 
Procedure EmitForms;
982
 
 
983
 
var
984
 
  fp : PformRec;
985
 
begin
986
 
  { Start emitting forms }
987
 
  fp:=Formroot;
988
 
  while fp<>nil do
989
 
    begin
990
 
    EmitForm(fp);
991
 
    fp:=fp^.nextform;
992
 
    end;
993
 
end;
994
 
 
995
 
{ ------------------------------------------------------------------------
996
 
  Code to emit callbacks
997
 
  ------------------------------------------------------------------------ }
998
 
 
999
 
Procedure CollectCallbacks;
1000
 
 
1001
 
Var CurrentCb,CBwalk : PCBrec;
1002
 
    fp : PformRec;
1003
 
    cp : PControl;
1004
 
 
1005
 
begin
1006
 
  CbRoot:=nil;
1007
 
  CurrentCB:=cbroot;
1008
 
  fp:=formroot;
1009
 
  while fp<>nil do
1010
 
    begin
1011
 
    cp:=fp^.controls;
1012
 
    while cp<>nil do
1013
 
      begin
1014
 
      if cp^.props[CPcallback]<>'' then
1015
 
        if cbroot<>nil then
1016
 
          begin
1017
 
          cbwalk:=cbroot;
1018
 
          while cbwalk<>nil do
1019
 
            if upcase(cbwalk^.name)=upcase(cp^.props[CPcallback]) then
1020
 
              break
1021
 
            else
1022
 
              cbwalk:=cbwalk^.next;
1023
 
          if cbwalk=nil then
1024
 
            begin
1025
 
            new(currentcb^.next);
1026
 
            currentcb:=currentcb^.next;
1027
 
            currentcb^.name:=cp^.props[CPcallback];
1028
 
            currentcb^.next:=nil;
1029
 
            end;
1030
 
          end
1031
 
        else
1032
 
          begin
1033
 
          new(cbroot);
1034
 
          currentcb:=cbroot;
1035
 
          cbroot^.name:=cp^.props[CPcallback];
1036
 
          cbroot^.next:=nil;
1037
 
          end;
1038
 
      cp:=cp^.nextcontrol;
1039
 
      end;
1040
 
    fp:=fp^.nextform;
1041
 
    end;
1042
 
end;
1043
 
 
1044
 
Procedure EmitCallback (Const s : string);
1045
 
 
1046
 
begin
1047
 
  writeln (OutFile,'Procedure ',s,' (Sender: PFL_OBJECT; Data : Longint); export;');
1048
 
  writeln (OutFile);
1049
 
  writeln (OutFile,'begin');
1050
 
  writeln (OutFile,'  { Place your code here }');
1051
 
  writeln (OutFile,'end;');
1052
 
  writeln (OutFile);
1053
 
end;
1054
 
 
1055
 
Procedure EmitCallBacks;
1056
 
 
1057
 
var cb : pcbrec;
1058
 
 
1059
 
begin
1060
 
  { See if we must emit callback stubs }
1061
 
  If Optionsset[1] then
1062
 
    begin
1063
 
    cb:=cbroot;
1064
 
    while cb<>nil do
1065
 
      begin
1066
 
      EmitCallBack(cb^.Name);
1067
 
      cb:=cb^.next;
1068
 
      end;
1069
 
    end;
1070
 
end;
1071
 
 
1072
 
 
1073
 
{ ------------------------------------------------------------------------
1074
 
  EmitterTable initialization Code
1075
 
  ------------------------------------------------------------------------ }
1076
 
 
1077
 
Procedure EmitDummy (cp : PControl;ObjClass : ObjClasses);
1078
 
 
1079
 
begin
1080
 
end;
1081
 
 
1082
 
Procedure InitEmitters;
1083
 
 
1084
 
var i : objclasses;
1085
 
 
1086
 
begin
1087
 
  EmitProcs[APClass]:=@EmitDummy;
1088
 
  EmitProcs[APBoxtype]:=@EmitBoxType;
1089
 
  EmitProcs[APColors]:=@EmitColors;
1090
 
  EmitProcs[APAlignment]:=@EmitAlignment;
1091
 
  EmitProcs[APlcol]:=@EmitLcol;
1092
 
  EmitProcs[APsize]:=@EmitSize;
1093
 
  EmitProcs[APStyle]:=@EmitStyle;
1094
 
  EmitProcs[APgravity]:=@EmitGravity;
1095
 
  for i:=FL_INVALID to FL_FOLDER do
1096
 
    ClassEmitters[i]:=EmitProp(Nil);
1097
 
end;
1098
 
 
1099
 
{ ------------------------------------------------------------------------
1100
 
  Main program Code
1101
 
  ------------------------------------------------------------------------ }
1102
 
 
1103
 
 
1104
 
begin
1105
 
  { Process options }
1106
 
  DoOptions;
1107
 
  { Read input file }
1108
 
  OpenFile;
1109
 
  DoPreamble;
1110
 
  DoForms;
1111
 
  DoPostamble;
1112
 
  CloseFile;
1113
 
  { Write output file }
1114
 
  OpenOutfile;
1115
 
  InitEmitters;
1116
 
  CollectCallbacks;
1117
 
  EmitHeader;
1118
 
  EmitCallbacks;
1119
 
  EmitForms;
1120
 
  EmitFooter;
1121
 
  CloseOutFile;
1122
 
end.