"Fossies" - the Fresh Open Source Software Archive 
Member "FreeBASIC-1.09.0-win64/examples/manual/samples.bas" (1 Jan 2022, 17439 Bytes) of package /windows/misc/FreeBASIC-1.09.0-win64.zip:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Visual Basic source code syntax highlighting (style:
standard) with prefixed line numbers.
Alternatively you can here
view or
download the uninterpreted source code file.
1 '' --------------------------------------------------------
2 '' FBWIKI Samples Builder
3 '' --------------------------------------------------------
4 ''
5 '' compile with
6 '' fbc samples.bas
7 ''
8 '' then execute with
9 '' samples[.exe]
10 ''
11 '' --------------------------------------------------------
12 ''
13 '' NOTES:
14 ''
15 '' Internally, we use "/" for the path seperator *always*.
16 '' The special build file samples.ini uses "/" in all paths
17 '' The "/" is flipped to "\" only when needed.
18 ''
19 '' IDEAS:
20 '' - add an option to generate a makefile that performs the
21 '' same function as this utility
22 '' - allow compiling for gcc (C/C++) programs
23 '' - more options (in samples.ini ) to exclude certain
24 '' samples based on platform DOS, LINUX, WIN32, etc
25 ''
26 '' --------------------------------------------------------
27
28 #include once "dir.bi"
29
30 #ifndef false
31 #define FALSE 0
32 #endif
33 #ifndef true
34 #define TRUE -1
35 #endif
36 #ifndef NULL
37 #define NULL 0
38 #endif
39
40 #include once "file.bi"
41
42 #if (defined( __FB_LINUX__ ) or defined( __FB_FREEBSD__ ))
43 #define __UNIX__
44 #define PLATFORM "LINUX"
45
46 #elseif (defined( __FB_WIN32__ ) or defined( __FB_CYGWIN__ ) or defined( __FB_XBOX__ ))
47 #define PLATFORM "WIN32"
48
49 #elseif (defined( __FB_DOS__ ))
50 #define PLATFORM "DOS32"
51
52 #else
53 #error TARGET NOT SUPPORTED
54
55 #endif
56
57 #define FWD_SLASH "/"
58 #define BACK_SLASH "\"
59
60 #ifdef __UNIX__
61 const exe_ext = ""
62 const dll_ext = ".so"
63 const psc = FWD_SLASH
64 #else
65 const exe_ext = ".exe"
66 const psc = BACK_SLASH
67 const dll_ext = ".dll"
68 #endif
69
70 enum COMMAND_ID
71 CMD_COMPILE = 1
72 CMD_CLEAN
73 CMD_LIST
74 end enum
75
76 enum BUILD_RESULT
77 BUILD_FAIL
78 BUILD_SUCCESS
79 BUILD_NOT_NEEDED
80 end enum
81
82 '' --------------------------------------------------------
83 '' HELPERS
84 '' --------------------------------------------------------
85
86 ''
87 function SetPathChars( byref s as string, byref p as string ) as string
88 dim i as integer, r as string
89
90 r = s
91 for i = 0 to len(s) - 1
92 if(( r[i] = asc(FWD_SLASH) ) or ( r[i] = asc(BACK_SLASH) )) then
93 r[i] = asc(p)
94 end if
95 next
96 function = r
97
98 end function
99
100 ''
101 function AdjustPath( byref s as string, byref p as string = "" ) as string
102 dim ret as string
103 #ifdef __UNIX__
104 ret = s
105 #else
106 ret = lcase(s)
107 #endif
108 if( len(p) > 0 ) then
109 select case right(ret,1)
110 case FWD_SLASH, BACK_SLASH
111 case else
112 ret = ret & p
113 end select
114 end if
115 function = ret
116 end function
117
118 ''
119 function ReplaceSubStr _
120 ( _
121 byref src as string, _
122 byref old as string, _
123 byref rep as string _
124 ) as string
125
126 dim i as integer = 1, ret as string
127 ret = src
128 do
129 i = instr(i, ret, old)
130 if i = 0 then exit do
131 ret = left(ret, i - 1) + rep + mid(ret, i + len(old))
132 i += len(rep)
133 loop
134 return ret
135
136 end function
137
138 '' --------------------------------------------------------
139 '' SPECIAL BUILDS
140 '' --------------------------------------------------------
141
142 type SpecialBuildFileT
143 source as string
144 index1 as integer
145 index2 as integer
146 end type
147
148 enum SpecialBuildStep
149 SBS_INVALID
150 SBS_SRC
151 SBS_DST
152 SBS_CMD
153 SBS_DEP
154 end enum
155
156 type SpecialBuildCmdT
157 buildstep as SpecialBuildStep
158 value as string
159 end type
160
161 '' Special Build Information
162 dim shared sbFiles() as SpecialBuildFileT
163 dim shared nsbFiles as integer
164 dim shared sbCmds() as SpecialBuildCmdT
165 dim shared nsbCmds as integer
166 dim shared opt_error as integer
167
168 ''
169 sub ReadSampleIni( byref filename as string )
170
171 dim h as integer, x as string, i as integer, skiptonext as integer
172 dim v as string, t as string, p as string
173 dim buildstep as SpecialBuildStep
174 h = freefile
175
176 nsbFiles = 0
177 redim sbFiles(0)
178 nsbCmds = 0
179 redim sbCmds(0)
180
181 if( open( filename for input access read as #h ) = 0 ) then
182 skiptonext = FALSE
183 while eof(h) = 0
184 line input #h, x
185 x = trim( x, any chr(9,32) )
186 if( (x > "") and (left(x, 1) <> "#") ) then
187 if( (left(x, 1) = "[") and (right(x, 1) = "]") ) then
188 skiptonext = FALSE
189 nsbfiles += 1
190 redim preserve sbFiles( 0 to nsbFiles - 1 )
191 with sbFiles( nsbFiles - 1 )
192 .source = SetPathChars( trim( mid( x, 2, len(x) - 2), any chr(9,32) ), FWD_SLASH )
193 .index1 = nsbCmds
194 .index2 = nsbCmds
195 end with
196 else
197 i = instr( x, "=" )
198 if( i > 0 ) then
199 v = trim( left( x, i - 1 ), any chr(9,32) )
200 t = trim( mid( x, i + 1 ), any chr(9,32) )
201 t = SetPathChars( t, FWD_SLASH )
202
203 '' Does v have a conditional target
204 i = instr( v, "," )
205 if( i > 0 ) then
206 p = ucase( trim( mid( v, i + 1 ), any chr(9,32) ) )
207 v = trim( left( v, i - 1 ), any chr(9,32) )
208
209 else
210 p = PLATFORM
211 end if
212
213 if( p = PLATFORM ) then
214
215 if( skiptonext = TRUE ) then
216 buildstep = SBS_INVALID
217
218 else
219
220 select case ucase(v)
221 case "SRC"
222 buildstep = SBS_SRC
223 case "DST"
224 buildstep = SBS_DST
225 case "CMD"
226 buildstep = SBS_CMD
227 case "DEP"
228 buildstep = SBS_DEP
229 case "SKP"
230 buildstep = SBS_INVALID
231 skiptonext = TRUE
232 case else
233 buildstep = SBS_INVALID
234 end select
235
236 end if
237
238 nsbCmds += 1
239 redim preserve sbCmds( 0 to nsbCmds - 1 )
240 with sbCmds( nsbCmds - 1 )
241 .buildstep = buildstep
242 .value = t
243 end with
244 sbFiles( nsbFiles - 1 ).index2 = nsbCmds
245
246 end if
247
248 end if
249
250 end if
251 end if
252 wend
253 close #h
254 else
255 print "Warning: Unable to open '" & filename & "'"
256 end if
257 end sub
258
259 ''
260 function GetSpecialBuildIndex( byref filename as string ) as integer
261 function = FALSE
262 dim i as integer
263 function = -1
264 for i = 0 to nsbFiles - 1
265 if( filename = sbFiles(i).source ) then
266 function = i
267 exit for
268 end if
269 next
270 end function
271
272 ''
273 function IsSpecialBuild( byref filename as string ) as integer
274 function = ( GetSpecialBuildIndex( filename ) >= 0 )
275 end function
276
277 '' --------------------------------------------------------
278
279 ''
280 sub AddDir( byref d as string, dirs() as string, byref ndirs as integer )
281 dim i as integer
282 for i = 1 to ndirs
283 if( dirs(i) = d ) then
284 exit for
285 end if
286 next
287 if( i > ndirs ) then
288 ndirs += 1
289 if ndirs = 1 then
290 redim dirs( 1 to ndirs )
291 else
292 redim preserve dirs( 1 to ndirs )
293 end if
294 dirs( ndirs ) = d
295 end if
296 end sub
297
298 ''
299 sub ScanDirectories _
300 ( _
301 byref sourcedir as string, _
302 byref sourcedir2 as string, _
303 dirs() as string, byref ndirs as integer _
304 )
305
306 dim d as string, i as integer, b as integer, start as integer
307
308 '' get directories
309 start = ndirs + 1
310 d = dir( sourcedir & sourcedir2 & "*.*", fbDirectory )
311 while( d > "" )
312 if(( d <> "." ) and ( d <> ".." )) then
313 AddDir( sourcedir2 & d & FWD_SLASH, dirs(), ndirs )
314 end if
315 d = dir()
316 wend
317
318 for i = start to ndirs
319
320 '' NOTE: we don't pass dirs(i) directly to ScanDirectories()
321 '' because dirs() might get resized, and the descriptor
322 '' relocated, corrupting the stack since ScanDirectories()
323 '' is called recursively.
324
325 dim tmp as string
326 tmp = dirs(i)
327 ScanDirectories( sourcedir, tmp, dirs(), ndirs )
328
329 next
330
331 end sub
332
333 ''
334 sub ScanFiles _
335 ( _
336 byref sourcedir as string, _
337 dirs() as string, byval ndirs as integer, _
338 files() as string, byref nfiles as integer _
339 )
340
341 dim d as string, i as integer
342
343 '' get files
344 nfiles = 0
345 for i = 1 to ndirs
346 d = dir( sourcedir & dirs(i) & "*.*" )
347 while( d > "" )
348 if( lcase( right( d, 2 )) = ".c" or lcase(right( d, 4 )) = ".bas" ) then
349 nfiles += 1
350 if nfiles = 1 then
351 redim files( 1 to nfiles)
352 else
353 redim preserve files( 1 to nfiles )
354 end if
355 files( nfiles ) = dirs(i) & d
356 end if
357 d = dir()
358 wend
359 next
360
361 end sub
362
363 ''
364 function IsFileNewer _
365 ( _
366 byref sourcedir as string, _
367 byref source as string, _
368 byref target as string _
369 ) as integer
370
371 if(( source > "" ) and ( target > "" )) then
372 if( fileexists( sourcedir & target ) <> FALSE ) then
373 if FileDateTime( sourcedir & source ) > FileDateTime( sourcedir & target ) then
374 function = TRUE
375 else
376 function = FALSE
377 end if
378 else
379 function = TRUE
380 end if
381 else
382 function = TRUE
383 end if
384
385 end function
386
387 ''
388 function DoCompile _
389 ( _
390 byref sourcedir as string, _
391 byref fbc as string, _
392 byref source as string, _
393 byref target as string, _
394 byref opts as string _
395 ) as integer
396
397 dim i as integer
398 dim args as string
399
400 if( IsFileNewer( sourcedir, source, target ) = TRUE ) then
401
402 dim h as integer = freefile, idx as integer, ret as integer
403
404 if open( sourcedir & source for binary access read as #h ) = 0 then
405
406 dim body as string
407 body = space( lof( h ))
408 get #h,,body
409 close #h
410
411 args = sourcedir & source
412
413 args += " " & opts & " -x " & sourcedir & target
414
415 print fbc & " " & args
416 ret = exec( fbc, args )
417 print
418
419 function = iif( ret = 0, BUILD_SUCCESS, BUILD_FAIL )
420
421 else
422 print "Error reading '" & sourcedir & source & "'"
423
424 function = BUILD_FAIL
425
426 end if
427
428 else
429 function = BUILD_NOT_NEEDED
430
431 end if
432
433 end function
434
435 ''
436 function DoClean _
437 ( _
438 byref sourcedir as string, _
439 byref source as string, _
440 byref target as string _
441 ) as integer
442
443 function = BUILD_SUCCESS
444
445 if( fileexists(sourcedir & source) <> FALSE ) then
446 if( fileexists(sourcedir & target) <> FALSE ) then
447 print "removing " & sourcedir & target
448 if( kill( sourcedir & target ) <> 0 ) then
449 print "error removing " & sourcedir & target
450 function = BUILD_FAIL
451 end if
452 end if
453 end if
454
455 end function
456
457 ''
458 function DoSpecialBuild _
459 ( _
460 byval cmd as COMMAND_ID, _
461 byref sourcedir as string, _
462 byref fbc as string, _
463 byref source as string, _
464 byref newest as double = 0 _
465 ) as integer
466
467 dim as integer i, j, k, ret
468 dim as integer first, last
469 dim as string v, args
470 dim as integer haderror, hadbuild, dobuild
471 dim as double d
472
473 function = BUILD_FAIL
474 haderror = FALSE
475
476 i = GetSpecialBuildIndex( source )
477 if( i < 0 ) then
478 exit function
479 end if
480
481 first = sbFiles(i).index1
482 last = sbFiles(i).index2 - 1
483
484 if( last - first < 0 ) then
485 function = BUILD_NOT_NEEDED
486 exit function
487 end if
488
489 dobuild = FALSE '' have option to force this?
490 hadbuild = FALSE
491
492 '' Do the dependencies first
493 for j = first to last
494 if( sbCmds(j).buildstep = SBS_DEP ) then
495 ret = DoSpecialBuild( cmd, sourcedir, fbc, sbCmds(j).value, newest )
496 if( ret = BUILD_FAIL ) then
497 haderror = TRUE
498 if( opt_error ) then
499 exit function
500 end if
501 elseif( ret = BUILD_SUCCESS ) then
502 hadbuild = TRUE
503 end if
504 end if
505 next
506
507 select case cmd
508 case CMD_COMPILE
509
510 dobuild OR= hadbuild
511
512 ''
513 if( dobuild = FALSE ) then
514
515 '' Any DST file missing
516
517 for j = first to last
518 if( sbCmds(j).buildstep = SBS_DST ) then
519
520 args = sbCmds(j).value
521 args = ReplaceSubStr( args, "$(EXEEXT)", exe_ext )
522 args = ReplaceSubStr( args, "$(DLLEXT)", dll_ext )
523
524 if( fileexists( sourcedir & args ) = FALSE ) then
525 dobuild = TRUE
526 exit for
527 end if
528 end if
529 next
530
531 end if
532
533 ''
534 if( dobuild = FALSE ) then
535
536 '' Get newest SRC file (or DEP, it might already be set)
537
538 if( fileexists( sourcedir & source ) ) then
539 d = filedatetime( sourcedir & source )
540 if( d > newest ) then
541 newest = d
542 end if
543 end if
544
545 for j = first to last
546 if( sbCmds(j).buildstep = SBS_SRC ) then
547 if( fileexists( sourcedir & sbCmds(j).value ) ) then
548 d = filedatetime( sourcedir & sbCmds(j).value )
549 if( d > newest ) then
550 newest = d
551 end if
552 end if
553 end if
554 next j
555
556 '' Any DST files older than newest date?
557 for j = first to last
558 if( sbCmds(j).buildstep = SBS_DST ) then
559
560 args = sbCmds(j).value
561 args = ReplaceSubStr( args, "$(EXEEXT)", exe_ext )
562 args = ReplaceSubStr( args, "$(DLLEXT)", dll_ext )
563
564 if( fileexists( sourcedir & args ) ) then
565
566 d = filedatetime( sourcedir & args )
567 if( d < newest ) then
568 dobuild = TRUE
569 exit for
570 end if
571
572 else
573
574 '' This was already checked, but anyway ...
575 dobuild = TRUE
576 exit for
577
578 end if
579 end if
580 next
581 end if
582
583 ''
584 if( dobuild ) then
585
586 '' At least one file is out of date or missing,
587 '' so do this special build
588
589 for j = first to last
590 select case sbCmds(j).buildstep
591 case SBS_CMD
592
593 args = sbCmds(j).value
594 args = ReplaceSubStr( args, "$(EXEEXT)", exe_ext )
595 args = ReplaceSubStr( args, "$(DLLEXT)", dll_ext )
596
597 print fbc & " " & args
598 ret = exec( fbc, args )
599 if( ret <> 0 ) then
600 haderror = TRUE
601 if( opt_error ) then
602 exit function
603 end if
604 end if
605 print
606
607 end select
608 next
609
610 function = iif( haderror = FALSE, BUILD_SUCCESS, BUILD_FAIL )
611
612 else
613 function = BUILD_NOT_NEEDED
614
615 end if
616
617 '' Get the newest date of all DST files
618 for j = first to last
619 if( sbCmds(j).buildstep = SBS_DST ) then
620 if( fileexists( sbFiles(i).source ) ) then
621 d = filedatetime( sbFiles(i).source )
622 if( d > newest ) then
623 newest = d
624 end if
625 end if
626 end if
627 next
628
629 case CMD_CLEAN
630
631 for j = first to last
632 if( sbCmds(j).buildstep = SBS_DST ) then
633
634 args = sbCmds(j).value
635 args = ReplaceSubStr( args, "$(EXEEXT)", exe_ext )
636 args = ReplaceSubStr( args, "$(DLLEXT)", dll_ext )
637
638 if( DoClean( sourcedir, sbFiles(i).source, args ) = BUILD_FAIL ) then
639 haderror = TRUE
640 if( opt_error ) then
641 exit function
642 end if
643 end if
644
645 end if
646 next
647
648 function = iif( haderror = FALSE, BUILD_SUCCESS, BUILD_FAIL )
649
650 end select
651
652
653
654 end function
655
656
657 '' --------------------------------------------------------
658 '' MAIN
659 '' --------------------------------------------------------
660
661 dim fbc as string, sourcedir as string, i as integer
662 dim opt_specialonly as integer
663 dim dirs() as string, ndirs as integer
664 dim files() as string, nfiles as integer
665 dim haderror as integer
666 dim extra_opts as string = ""
667
668 ndirs = 0
669 nfiles = 0
670
671 opt_specialonly = FALSE
672 opt_error = FALSE
673 haderror = FALSE
674
675 dim cmd as COMMAND_ID
676
677 '' parse command line command
678 i = 1
679 select case lcase(command(i))
680 case "compile"
681 cmd = CMD_COMPILE
682
683 case "clean"
684 cmd = CMD_CLEAN
685
686 case "list"
687 cmd = CMD_LIST
688
689 case else
690 print "samples command [options] [dirs...]"
691 print
692 print " Command:"
693 print " compile compiles the samples"
694 print " clean removes files created during compilation"
695 print " list list the files only"
696 print
697 print " Options:"
698 print " -fbc path" & psc & "fbc" & exe_ext
699 print " Sets path and name of the fbc compiler to use when"
700 print " building the samples. Default is .." & psc & ".." & psc & "fbc" & exe_ext
701 print
702 print " -srcdir path"
703 print " Set the base directory of the samples to build."
704 print " Default is " & exepath & psc
705 print
706 print " dirs..."
707 print " Specify the names of the directories (without paths) to build."
708 print " Default is to build all. e.g. proguide/arrays"
709 print
710 print " -special"
711 print " Only process the special builds. (Files listed in samples.ini)"
712 print
713 print " -error"
714 print " Abort on first error detected"
715 print
716 print " -opts options"
717 print " Add options to the command line"
718 print
719 end
720 end select
721
722 '' parse command line options
723 i += 1
724 while( command(i) > "" )
725 if( left( command(i), 1 ) = "-" ) then
726
727 select case lcase(command(i))
728 case "-fbc"
729 i += 1
730 fbc = SetPathChars( command(i), psc )
731 fbc = AdjustPath( fbc )
732
733 case "-srcdir"
734 i += 1
735 sourcedir = SetPathChars( command(i), FWD_SLASH )
736 sourcedir = AdjustPath( sourcedir, FWD_SLASH )
737
738 case "-special"
739 opt_specialonly = TRUE
740
741 case "-error"
742 opt_error = TRUE
743
744 case "-opts"
745 i += 1
746 extra_opts = command(i)
747
748 case else
749 print "Unrecognized option '" & command(i) & "'"
750 end 1
751
752 end select
753
754 else
755 dim tmp as string
756 tmp = SetPathChars( command(i), FWD_SLASH )
757 tmp = AdjustPath( tmp, FWD_SLASH )
758 AddDir( tmp, dirs(), ndirs )
759
760 end if
761
762 i += 1
763
764 wend
765
766 if( sourcedir = "" ) then
767 sourcedir = SetPathChars( exepath, FWD_SLASH )
768 sourcedir = AdjustPath( sourcedir, FWD_SLASH )
769 end if
770
771 if( cmd = CMD_COMPILE ) then
772
773 if( fbc = "" ) then
774 fbc = ".." & FWD_SLASH & ".." & FWD_SLASH & "fbc" & exe_ext
775 end if
776
777 if( fileexists( fbc ) = 0 ) then
778 print "'" & fbc & "' not found"
779 end 1
780 end if
781
782 end if
783
784 '' Scan for directories and files
785 if( nDirs > 0 ) then
786 for i = 1 to nDirs
787 dim tmp as string
788 tmp = dirs(i)
789 ScanDirectories( sourcedir, tmp, dirs(), ndirs )
790 next
791 else
792 ScanDirectories( sourcedir, "", dirs(), ndirs )
793 end if
794
795 ScanFiles( sourcedir, dirs(), ndirs, files(), nfiles )
796
797 dim as string source, target
798
799 ReadSampleIni( exepath & FWD_SLASH & "samples.ini" )
800
801 select case cmd
802 case CMD_LIST
803 for i = 1 to nfiles
804 print files(i)
805 next
806
807 case CMD_COMPILE, CMD_CLEAN
808
809 for i = 1 to nfiles
810 if( IsSpecialBuild( files(i) ) ) then
811
812 if( DoSpecialBuild( cmd, sourcedir, fbc, files(i) ) = BUILD_FAIL ) then
813 haderror = TRUE
814 if( opt_error ) then
815 exit for
816 end if
817 end if
818
819 elseif( opt_specialonly = FALSE ) then
820
821 dim target as string
822 target = left(files(i), len(files(i))-4) & exe_ext
823
824 if( cmd = CMD_COMPILE ) then
825 if( DoCompile( sourcedir, fbc, files(i), target, extra_opts ) = BUILD_FAIL ) then
826 haderror = TRUE
827 if( opt_error ) then
828 exit for
829 end if
830 end if
831
832 else
833 if( DoClean( sourcedir, files(i), target ) = BUILD_FAIL ) then
834 haderror = TRUE
835 if( opt_error ) then
836 exit for
837 end if
838 end if
839
840 end if
841
842 end if
843 next
844
845 end select
846
847 if( haderror ) then
848 end 1
849 end if