diff options
| -rw-r--r-- | bin/.gitignore | 4 | ||||
| -rw-r--r-- | doc/filename.html | 304 | ||||
| -rw-r--r-- | doc/fl_file_chooser.html | 9 | ||||
| -rw-r--r-- | doc/index.html | 2 | ||||
| -rw-r--r-- | progress.txt | 12 | ||||
| -rw-r--r-- | src/c_fl_error.cpp | 14 | ||||
| -rw-r--r-- | src/c_fl_error.h | 3 | ||||
| -rw-r--r-- | src/c_fl_file_chooser.cpp | 20 | ||||
| -rw-r--r-- | src/c_fl_file_chooser.h | 3 | ||||
| -rw-r--r-- | src/c_fl_filename.cpp | 127 | ||||
| -rw-r--r-- | src/c_fl_filename.h | 39 | ||||
| -rw-r--r-- | src/fltk-file_choosers.adb | 31 | ||||
| -rw-r--r-- | src/fltk-file_choosers.ads | 7 | ||||
| -rw-r--r-- | src/fltk-filenames.adb | 484 | ||||
| -rw-r--r-- | src/fltk-filenames.ads | 157 | ||||
| -rw-r--r-- | test.gpr | 31 | ||||
| -rw-r--r-- | test/compare.adb | 45 | ||||
| -rw-r--r-- | test/dirlist.adb | 93 |
18 files changed, 1370 insertions, 15 deletions
diff --git a/bin/.gitignore b/bin/.gitignore new file mode 100644 index 0000000..ea7f887 --- /dev/null +++ b/bin/.gitignore @@ -0,0 +1,4 @@ + + +* +!.gitignore diff --git a/doc/filename.html b/doc/filename.html new file mode 100644 index 0000000..a922359 --- /dev/null +++ b/doc/filename.html @@ -0,0 +1,304 @@ +<!DOCTYPE html> + +<html lang="en"> + <head> + <meta charset="utf-8"> + <title>Filename Binding Map</title> + <link href="map.css" rel="stylesheet"> + </head> + + <body> + + +<h2>Filename Binding Map</h2> + + +<a href="index.html">Back to Index</a> + + +<table class="package"> + <tr><th colspan="2">Package name</th></tr> + + <tr> + <td>filename</td> + <td>FLTK.Filenames</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Types</th></tr> + + <tr> + <td>char *</td> + <td>Path_String</td> + </tr> + + <tr> + <td>int</td> + <td>Comparison</td> + </tr> + + <tr> + <td>Fl_File_Sort_F</td> + <td>Compare_Function</td> + </tr> + + <tr> + <td>struct dirent ***</td> + <td>File_List</td> + </tr> + +</table> + + + +<table class="type"> + <tr><th colspan="2">Errors</th></tr> + + <tr> + <td>char * msg</td> + <td>Open_URI_Error</td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Attributes</th></tr> + + <tr> +<td><pre> +#define FL_PATH_MAX 2048 +</pre></td> +<td><pre> +Max_Path_Length : constant Natural; +</pre></td> + </tr> + +</table> + + + +<table class="function"> + <tr><th colspan="2">Functions and Procedures</th></tr> + + <tr> +<td><pre> +int fl_alphasort(struct dirent **, struct dirent **); +</pre></td> +<td><pre> +function Alpha_Sort + (A, B : in String) + return Comparison; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_casealphasort(struct dirent **, struct dirent **); +</pre></td> +<td><pre> +function Case_Alpha_Sort + (A, B : in String) + return Comparison; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_casenumericsort(struct dirent **, struct dirent **); +</pre></td> +<td><pre> +function Case_Numeric_Sort + (A, B : in String) + return Comparison; +</pre></td> + </tr> + + <tr> +<td><pre> +void fl_decode_uri(char *uri); +</pre></td> +<td><pre> +function Decode_URI + (URI : in Path_String) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_filename_absolute(char *to, int tolen, const char *from); +</pre></td> +<td><pre> +function Absolute + (Name : in Path_String) + return Path_String; + +function Absolute + (Name : in Path_String; + Changed : out Boolean) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_filename_expand(char *to, int tolen, const char *from); +</pre></td> +<td><pre> +function Expand + (Name : in Path_String) + return Path_String; + +function Expand + (Name : in Path_String; + Changed : out Boolean) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_filename_ext(const char *buf); +</pre></td> +<td><pre> +function Extension + (Name : in Path_String) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +void fl_filename_free_list(struct dirent ***l, int n); +</pre></td> +<td>Automatically called when a File_List goes out of scope.</td> + </tr> + + <tr> +<td><pre> +int fl_filename_isdir(const char *name); +</pre></td> +<td><pre> +function Is_Directory + (Name : in Path_String) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_filename_list(const char *d, struct dirent ***l, + Fl_File_Sort_F *s=fl_numericsort); +</pre></td> +<td><pre> +function Get_Listing + (Name : in Path_String; + Sort : in not null Compare_Function := + Numeric_Sort'Access) + return File_List; +</pre></td> + </tr> + + <tr> +<td>Tracking of the return value of fl_filename_list must be done manually.</td> +<td><pre> +function Length + (This : in File_List) + return Natural; +</pre></td> + </tr> + + <tr> +<td>Dereferencing of a dirent struct must be done manually.</td> +<td><pre> +function Item + (This : in File_List; + Index : in Positive) + return Path_String +with Pre => Index in 1 .. This.Length; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_filename_match(const char *name, const char *pattern); +</pre></td> +<td><pre> +function Match + (Input, Pattern : in String) + return Boolean; +</pre></td> + </tr> + + <tr> +<td><pre> +const char * fl_filename_name(const char *filename); +</pre></td> +<td><pre> +function Base_Name + (Name : in Path_String) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_filename_relative(char *to, int tolen, const char *from); +</pre></td> +<td><pre> +function Relative + (Name : in Path_String) + return Path_String; + +function Relative + (Name : in Path_String; + Changed : out Boolean) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +char * fl_filename_setext(char *to, int tolen, const char *ext); +</pre></td> +<td><pre> +function Set_Extension + (Name : in Path_String; + Suffix : in String) + return Path_String; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_numericsort(struct dirent **, struct dirent **); +</pre></td> +<td><pre> +function Numeric_Sort + (A, B : in String) + return Comparison; +</pre></td> + </tr> + + <tr> +<td><pre> +int fl_open_uri(const char *uri, char *msg, int msglen); +</pre></td> +<td><pre> +procedure Open_URI + (URI : in Path_String); +</pre></td> + </tr> + +</table> + + + </body> +</html> + diff --git a/doc/fl_file_chooser.html b/doc/fl_file_chooser.html index f43989d..06dab72 100644 --- a/doc/fl_file_chooser.html +++ b/doc/fl_file_chooser.html @@ -295,7 +295,10 @@ procedure Set_Show_Label <td><pre> static Fl_File_Sort_F * sort = fl_numericsort; </pre></td> -<td>TBA</td> +<td><pre> +Sort_Method : not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access; +</pre></td> </tr> </table> @@ -687,14 +690,14 @@ procedure Set_Chooser_Kind <td><pre> void * user_data() const; </pre></td> -<td> </td> +<td>Not used in public API.</td> </tr> <tr> <td><pre> void user_data(void *d); </pre></td> -<td> </td> +<td>Not used in public API.</td> </tr> <tr> diff --git a/doc/index.html b/doc/index.html index 7e78aba..d58e2da 100644 --- a/doc/index.html +++ b/doc/index.html @@ -17,6 +17,7 @@ <ul> <li><a href="fl.html">Enumerations</a></li> + <li><a href="filename.html">Filename</a></li> <li><a href="fl.html">Fl</a></li> <li><a href="fl_adjuster.html">Fl_Adjuster</a></li> <li><a href="fl_ask.html">Fl_Ask</a></li> @@ -148,6 +149,7 @@ <li><a href="fl.html">FLTK.Errors</a></li> <li><a href="fl.html">FLTK.Event</a></li> <li><a href="fl_file_chooser.html">FLTK.File_Choosers</a></li> + <li><a href="filename.html">FLTK.Filenames</a></li> <li><a href="fl_help_dialog.html">FLTK.Help_Dialogs</a></li> <li><a href="fl_image.html">FLTK.Images</a></li> <li><a href="fl_bitmap.html">FLTK.Images.Bitmaps</a></li> diff --git a/progress.txt b/progress.txt index f8d367a..274c603 100644 --- a/progress.txt +++ b/progress.txt @@ -21,16 +21,18 @@ To move from 'Done' to 'Polished' the implementation details must be double chec Polished: FLTK +FLTK.Asks FLTK.Devices FLTK.Devices.Surfaces.Copy FLTK.Devices.Surfaces.Image FLTK.Devices.Surfaces.Paged FLTK.Devices.Surfaces.Paged.Printers -FLTK.Dialogs FLTK.Draw FLTK.Environment +FLTK.Errors FLTK.Event FLTK.File_Choosers +FLTK.Filenames FLTK.Help_Dialogs FLTK.Images FLTK.Images.Bitmaps @@ -89,12 +91,12 @@ FLTK.Widgets.Groups.Windows.Single.Menu FLTK.Widgets.Groups.Wizards FLTK.Widgets.Inputs FLTK.Widgets.Inputs.File -FLTK.Widgets.Inputs.Float -FLTK.Widgets.Inputs.Integer +FLTK.Widgets.Inputs.Floating_Point FLTK.Widgets.Inputs.Multiline FLTK.Widgets.Inputs.Outputs FLTK.Widgets.Inputs.Outputs.Multiline FLTK.Widgets.Inputs.Secret +FLTK.Widgets.Inputs.Whole_Number FLTK.Widgets.Menus FLTK.Widgets.Menus.Choices FLTK.Widgets.Menus.Menu_Bars @@ -110,9 +112,9 @@ FLTK.Widgets.Valuators.Dials.Line FLTK.Widgets.Valuators.Rollers FLTK.Widgets.Valuators.Sliders FLTK.Widgets.Valuators.Sliders.Fill -FLTK.Widgets.Valuators.Sliders.Hor_Fill -FLTK.Widgets.Valuators.Sliders.Hor_Nice FLTK.Widgets.Valuators.Sliders.Horizontal +FLTK.Widgets.Valuators.Sliders.Horizontal_Fill +FLTK.Widgets.Valuators.Sliders.Horizontal_Nice FLTK.Widgets.Valuators.Sliders.Nice FLTK.Widgets.Valuators.Sliders.Scrollbars FLTK.Widgets.Valuators.Sliders.Value diff --git a/src/c_fl_error.cpp b/src/c_fl_error.cpp index 17c45a0..2b83187 100644 --- a/src/c_fl_error.cpp +++ b/src/c_fl_error.cpp @@ -19,34 +19,34 @@ extern "C" void error_fatal_hook(const char * m); // This is the size used internally in FLTK anyway -const int bsize = 1024; +const int error_bsize = 1024; // Some prep needed to convert vargs to a single char* void warning_hook_prep(const char * m, ...) { va_list args; - char buf[bsize]; + char buf[error_bsize]; va_start(args, m); - vsnprintf(buf, bsize, m, args); + vsnprintf(buf, error_bsize, m, args); va_end(args); error_warning_hook(buf); } void error_hook_prep(const char * m, ...) { va_list args; - char buf[bsize]; + char buf[error_bsize]; va_start(args, m); - vsnprintf(buf, bsize, m, args); + vsnprintf(buf, error_bsize, m, args); va_end(args); error_error_hook(buf); } void fatal_hook_prep(const char * m, ...) { va_list args; - char buf[bsize]; + char buf[error_bsize]; va_start(args, m); - vsnprintf(buf, bsize, m, args); + vsnprintf(buf, error_bsize, m, args); va_end(args); error_fatal_hook(buf); } diff --git a/src/c_fl_error.h b/src/c_fl_error.h index 263a42b..b8ffb00 100644 --- a/src/c_fl_error.h +++ b/src/c_fl_error.h @@ -8,6 +8,9 @@ #define FL_ERROR_GUARD +extern "C" const int error_bsize; + + extern "C" void fl_error_default_warning(const char * m); extern "C" void fl_error_default_error(const char * m); extern "C" void fl_error_default_fatal(const char * m); diff --git a/src/c_fl_file_chooser.cpp b/src/c_fl_file_chooser.cpp index 4cf3e8e..3ca16e2 100644 --- a/src/c_fl_file_chooser.cpp +++ b/src/c_fl_file_chooser.cpp @@ -11,6 +11,26 @@ +// Exports from Ada + +extern "C" int file_chooser_sort_hook(const char * a, const char * b); + + + + +// Some extra setup + +int file_chooser_sort_prehook(struct dirent ** a, struct dirent ** b) { + return file_chooser_sort_hook((*a)->d_name, (*b)->d_name); +} + +void file_chooser_setup_sort_hook() { + Fl_File_Chooser::sort = &file_chooser_sort_prehook; +} + + + + // Flattened C API begins here FILECHOOSER new_fl_file_chooser(const char * n, const char * p, int k, const char * t) { diff --git a/src/c_fl_file_chooser.h b/src/c_fl_file_chooser.h index e5dcf05..17ee63c 100644 --- a/src/c_fl_file_chooser.h +++ b/src/c_fl_file_chooser.h @@ -11,6 +11,9 @@ typedef void* FILECHOOSER; +extern "C" void file_chooser_setup_sort_hook(); + + extern "C" FILECHOOSER new_fl_file_chooser(const char * n, const char * p, int k, const char * t); extern "C" void free_fl_file_chooser(FILECHOOSER f); diff --git a/src/c_fl_filename.cpp b/src/c_fl_filename.cpp new file mode 100644 index 0000000..39af3d1 --- /dev/null +++ b/src/c_fl_filename.cpp @@ -0,0 +1,127 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#include <FL/filename.H> +#include <string.h> +#include "c_fl_filename.h" + + + + +const int fl_path_max = FL_PATH_MAX; + + + + +void free_filename_file_list(void * l, int n) { + struct dirent ** p = reinterpret_cast<struct dirent **>(l); + fl_filename_free_list(&p, n); +} + +const char * filename_dname(void * l, int n) { + return (reinterpret_cast<struct dirent **>(l)[n])->d_name; +} + + + + +void filename_decode_uri(char *uri) { + fl_decode_uri(uri); +} + +int filename_absolute(char * to, int tolen, const char * from) { + return fl_filename_absolute(to, tolen, from); +} + +int filename_expand(char * to, int tolen, const char * from) { + return fl_filename_expand(to, tolen, from); +} + +const char * filename_ext(const char * buf) { + return fl_filename_ext(buf); +} + +int filename_isdir(const char * name) { + return fl_filename_isdir(name); +} + +int filename_list(const char * d, void * l, void * f) { + return fl_filename_list(d, reinterpret_cast<struct dirent ***>(l), + reinterpret_cast<Fl_File_Sort_F*>(f)); +} + +int filename_match(const char * name, const char * pattern) { + return fl_filename_match(name, pattern); +} + +const char * filename_name(const char * name) { + return fl_filename_name(name); +} + +int filename_relative(char * to, int tolen, const char * from) { + return fl_filename_relative(to, tolen, from); +} + +char * filename_setext(char * to, int tolen, const char * ext) { + return fl_filename_setext(to, tolen, ext); +} + +int filename_open_uri(const char * uri, char * msg, int msglen) { + return fl_open_uri(uri, msg, msglen); +} + + + + +int filename_alphasort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_alphasort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_casealphasort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_casealphasort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_numericsort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_numericsort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + +int filename_casenumericsort(char * a, char * b) { + struct dirent d_aye, d_bee; + d_aye.d_name[0] = '\0'; + strncat (d_aye.d_name, a, 255); + d_bee.d_name[0] = '\0'; + strncat (d_bee.d_name, b, 255); + struct dirent * dp_aye = &d_aye; + struct dirent * dp_bee = &d_bee; + int result = fl_casenumericsort(&dp_aye, &dp_bee); + return result < 0 ? 0 : result == 0 ? 1 : 2; +} + + diff --git a/src/c_fl_filename.h b/src/c_fl_filename.h new file mode 100644 index 0000000..0839293 --- /dev/null +++ b/src/c_fl_filename.h @@ -0,0 +1,39 @@ + + +// Programmed by Jedidiah Barber +// Released into the public domain + + +#ifndef FL_FILENAME_GUARD +#define FL_FILENAME_GUARD + + +extern "C" const int fl_path_max; + + +extern "C" void free_filename_file_list(void * l, int n); +extern "C" const char * filename_dname(void * l, int n); + + +extern "C" void filename_decode_uri(char *uri); +extern "C" int filename_absolute(char * to, int tolen, const char * from); +extern "C" int filename_expand(char * to, int tolen, const char * from); +extern "C" const char * filename_ext(const char * buf); +extern "C" int filename_isdir(const char * name); +extern "C" int filename_list(const char * d, void * l, void * f); +extern "C" int filename_match(const char * name, const char * pattern); +extern "C" const char * filename_name(const char * name); +extern "C" int filename_relative(char * to, int tolen, const char * from); +extern "C" char * filename_setext(char * to, int tolen, const char * ext); +extern "C" int filename_open_uri(const char * uri, char * msg, int msglen); + + +extern "C" int filename_alphasort(char * a, char * b); +extern "C" int filename_casealphasort(char * a, char * b); +extern "C" int filename_numericsort(char * a, char * b); +extern "C" int filename_casenumericsort(char * a, char * b); + + +#endif + + diff --git a/src/fltk-file_choosers.adb b/src/fltk-file_choosers.adb index 5363c51..db9768c 100644 --- a/src/fltk-file_choosers.adb +++ b/src/fltk-file_choosers.adb @@ -47,6 +47,13 @@ package body FLTK.File_Choosers is + procedure file_chooser_setup_sort_hook; + pragma Import (C, file_chooser_setup_sort_hook, "file_chooser_setup_sort_hook"); + pragma Inline (file_chooser_setup_sort_hook); + + + + function new_fl_file_chooser (N, P : in Interfaces.C.char_array; K : in Interfaces.C.int; @@ -459,6 +466,26 @@ package body FLTK.File_Choosers is + ---------------------- + -- Callback Hooks -- + ---------------------- + + function File_Chooser_Sort_Hook + (A, B : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + + pragma Export (C, File_Chooser_Sort_Hook, "file_chooser_sort_hook"); + + function File_Chooser_Sort_Hook + (A, B : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int is + begin + return Filenames.Comparison'Pos (Sort_Method + (Interfaces.C.Strings.Value (A), + Interfaces.C.Strings.Value (B))) - 1; + end File_Chooser_Sort_Hook; + + procedure File_Chooser_Callback_Hook (C_Addr, User_Data : in Storage.Integer_Address); @@ -1205,6 +1232,10 @@ package body FLTK.File_Choosers is end Is_Visible; +begin + + file_chooser_setup_sort_hook; + end FLTK.File_Choosers; diff --git a/src/fltk-file_choosers.ads b/src/fltk-file_choosers.ads index b350ddc..cea7b36 100644 --- a/src/fltk-file_choosers.ads +++ b/src/fltk-file_choosers.ads @@ -6,6 +6,7 @@ with + FLTK.Filenames, FLTK.Widgets.Buttons.Light.Check; private with @@ -46,6 +47,12 @@ package FLTK.File_Choosers is + Sort_Method : not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access; + + + + function New_Button (This : in out File_Chooser) return FLTK.Widgets.Buttons.Button_Reference; diff --git a/src/fltk-filenames.adb b/src/fltk-filenames.adb new file mode 100644 index 0000000..f8f31f0 --- /dev/null +++ b/src/fltk-filenames.adb @@ -0,0 +1,484 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Filenames is + + + ------------------------ + -- Constants From C -- + ------------------------ + + error_bsize : constant Interfaces.C.int; + pragma Import (C, error_bsize, "error_bsize"); + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + procedure free_filename_file_list + (L : in Storage.Integer_Address; + N : in Interfaces.C.int); + pragma Import (C, free_filename_file_list, "free_filename_file_list"); + pragma Inline (free_filename_file_list); + + function filename_dname + (L : in Storage.Integer_Address; + N : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_dname, "filename_dname"); + pragma Inline (filename_dname); + + + + + procedure filename_decode_uri + (URI : in Interfaces.C.char_array); + pragma Import (C, filename_decode_uri, "filename_decode_uri"); + pragma Inline (filename_decode_uri); + + function filename_absolute + (To : in Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_absolute, "filename_absolute"); + pragma Inline (filename_absolute); + + function filename_expand + (To : in Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_expand, "filename_expand"); + pragma Inline (filename_expand); + + function filename_ext + (Buf : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_ext, "filename_ext"); + pragma Inline (filename_ext); + + function filename_isdir + (Name : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_isdir, "filename_isdir"); + pragma Inline (filename_isdir); + + function filename_list + (D : in Interfaces.C.char_array; + L : out Storage.Integer_Address; + F : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, filename_list, "filename_list"); + pragma Inline (filename_list); + + function filename_match + (Name, Pattern : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_match, "filename_match"); + pragma Inline (filename_match); + + function filename_name + (Name : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_name, "filename_name"); + pragma Inline (filename_name); + + function filename_relative + (To : in Interfaces.C.char_array; + Len : in Interfaces.C.int; + From : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_relative, "filename_relative"); + pragma Inline (filename_relative); + + function filename_setext + (To : in Interfaces.C.char_array; + Len : in Interfaces.C.int; + Ext : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, filename_setext, "filename_setext"); + pragma Inline (filename_setext); + + function filename_open_uri + (U, M : in Interfaces.C.char_array; + Len : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, filename_open_uri, "filename_open_uri"); + pragma Inline (filename_open_uri); + + + + + function filename_alphasort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_alphasort, "filename_alphasort"); + + function filename_casealphasort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_casealphasort, "filename_casealphasort"); + + function filename_numericsort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_numericsort, "filename_numericsort"); + + function filename_casenumericsort + (A, B : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, filename_casenumericsort, "filename_casenumericsort"); + + + + + ------------------------------ + -- Comparison Subprograms -- + ------------------------------ + + function Alpha_Sort + (A, B : in String) + return Comparison + is + Result : Interfaces.C.int := + filename_alphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + if Result not in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last) then + raise Internal_FLTK_Error; + else + return Comparison'Val (Result); + end if; + end Alpha_Sort; + + + function Case_Alpha_Sort + (A, B : in String) + return Comparison + is + Result : Interfaces.C.int := + filename_casealphasort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + if Result not in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last) then + raise Internal_FLTK_Error; + else + return Comparison'Val (Result); + end if; + end Case_Alpha_Sort; + + + function Numeric_Sort + (A, B : in String) + return Comparison + is + Result : Interfaces.C.int := + filename_numericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + if Result not in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last) then + raise Internal_FLTK_Error; + else + return Comparison'Val (Result); + end if; + end Numeric_Sort; + + + function Case_Numeric_Sort + (A, B : in String) + return Comparison + is + Result : Interfaces.C.int := + filename_casenumericsort (Interfaces.C.To_C (A), Interfaces.C.To_C (B)); + begin + if Result not in Comparison'Pos (Comparison'First) .. Comparison'Pos (Comparison'Last) then + raise Internal_FLTK_Error; + else + return Comparison'Val (Result); + end if; + end Case_Numeric_Sort; + + + + + --------------------------- + -- Listing Subprograms -- + --------------------------- + + procedure Finalize + (This : in out File_List) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_filename_file_list (This.Void_Ptr, This.Entries); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + function Length + (This : in File_List) + return Natural is + begin + return Natural (This.Entries); + end Length; + + + function Item + (This : in File_List; + Index : in Positive) + return Path_String is + begin + return Interfaces.C.Strings.Value + (filename_dname (This.Void_Ptr, Interfaces.C.int (Index) - 1)); + end Item; + + + + + -------------------- + -- Filename API -- + -------------------- + + function Decode_URI + (URI : in Path_String) + return Path_String + is + C_Ptr : Interfaces.C.char_array := Interfaces.C.To_C (URI); + begin + filename_decode_uri (C_Ptr); + return Interfaces.C.To_Ada (C_Ptr); + end Decode_URI; + + + procedure Open_URI + (URI : in Path_String) + is + Message : Interfaces.C.char_array (1 .. Interfaces.C.size_t (error_bsize)) := + (others => Interfaces.C.char'Val (0)); + Result : Interfaces.C.int := filename_open_uri + (Interfaces.C.To_C (URI), + Message, + error_bsize); + begin + if Result = 0 then + raise Open_URI_Error with "Error: " & Interfaces.C.To_Ada (Message); + elsif Result /= 1 then + raise Internal_FLTK_Error; + end if; + end Open_URI; + + + + + function Absolute + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_absolute + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Absolute; + + + function Absolute + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_absolute + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Absolute; + + + function Relative + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_relative + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Relative; + + + function Relative + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_relative + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Relative; + + + function Expand + (Name : in Path_String) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_expand + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + return Interfaces.C.To_Ada (Result); + end Expand; + + + function Expand + (Name : in Path_String; + Changed : out Boolean) + return Path_String + is + Result : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Code : Interfaces.C.int := filename_expand + (Result, + Interfaces.C.int (Max_Path_Length), + Interfaces.C.To_C (Name)); + begin + Changed := Code /= 0; + return Interfaces.C.To_Ada (Result); + end Expand; + + + + + function Base_Name + (Name : in Path_String) + return Path_String + is + Data : Interfaces.C.char_array := Interfaces.C.To_C (Name); + begin + return Interfaces.C.Strings.Value (filename_name (Data)); + end Base_Name; + + + function Extension + (Name : in Path_String) + return Path_String + is + Data : Interfaces.C.char_array := Interfaces.C.To_C (Name); + Result : Interfaces.C.Strings.chars_ptr := filename_ext (Data); + begin + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Extension; + + + function Set_Extension + (Name : in Path_String; + Suffix : in String) + return Path_String + is + Data : Interfaces.C.char_array (1 .. Interfaces.C.size_t (Max_Path_Length)) := + (others => Interfaces.C.char'Val (0)); + Result : Interfaces.C.Strings.chars_ptr; + begin + Data (1 .. Name'Length) := Interfaces.C.To_C (Name); + Result := filename_setext + (Data, + Data'Length, + Interfaces.C.To_C (Suffix)); + return Interfaces.C.Strings.Value (Result); + end Set_Extension; + + + + + function Is_Directory + (Name : in Path_String) + return Boolean is + begin + return filename_isdir (Interfaces.C.To_C (Name)) /= 0; + end Is_Directory; + + + Current_Sort : Compare_Function; + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int; + + pragma Convention (C, Compare_Hook); + + function Compare_Hook + (DA, DB : in Storage.Integer_Address) + return Interfaces.C.int + is + Result : Comparison := Current_Sort + (Interfaces.C.Strings.Value (filename_dname (DA, 0)), + Interfaces.C.Strings.Value (filename_dname (DB, 0))); + begin + return Comparison'Pos (Result) - 1; + end Compare_Hook; + + function Get_Listing + (Name : in Path_String; + Sort : in not null Compare_Function := Numeric_Sort'Access) + return File_List is + begin + Current_Sort := Sort; + return This : File_List do + This.Entries := filename_list + (Interfaces.C.To_C (Name), + This.Void_Ptr, + Storage.To_Integer (Compare_Hook'Address)); + end return; + end Get_Listing; + + + + + function Match + (Input, Pattern : in String) + return Boolean is + begin + return filename_match (Interfaces.C.To_C (Input), Interfaces.C.To_C (Pattern)) /= 0; + end Match; + + +end FLTK.Filenames; + + diff --git a/src/fltk-filenames.ads b/src/fltk-filenames.ads new file mode 100644 index 0000000..2872b8c --- /dev/null +++ b/src/fltk-filenames.ads @@ -0,0 +1,157 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Filenames is + + + Max_Path_Length : constant Natural; + + subtype Path_String is String + with Dynamic_Predicate => Path_String'Length <= Max_Path_Length; + + + type Comparison is (Lesser, Equal, Greater); + + type Compare_Function is access function + (A, B : in String) + return Comparison; + + function Alpha_Sort + (A, B : in String) + return Comparison; + + function Case_Alpha_Sort + (A, B : in String) + return Comparison; + + function Numeric_Sort + (A, B : in String) + return Comparison; + + function Case_Numeric_Sort + (A, B : in String) + return Comparison; + + + type File_List is new Wrapper with private; + + function Length + (This : in File_List) + return Natural; + + function Item + (This : in File_List; + Index : in Positive) + return Path_String + with Pre => Index in 1 .. This.Length; + + + Open_URI_Error : exception; + + + + + function Decode_URI + (URI : in Path_String) + return Path_String; + + procedure Open_URI + (URI : in Path_String); + + + + + function Absolute + (Name : in Path_String) + return Path_String; + + function Absolute + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + function Relative + (Name : in Path_String) + return Path_String; + + function Relative + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + function Expand + (Name : in Path_String) + return Path_String; + + function Expand + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + + + + function Base_Name + (Name : in Path_String) + return Path_String; + + function Extension + (Name : in Path_String) + return Path_String; + + function Set_Extension + (Name : in Path_String; + Suffix : in String) + return Path_String; + + + + + function Is_Directory + (Name : in Path_String) + return Boolean; + + function Get_Listing + (Name : in Path_String; + Sort : in not null Compare_Function := Numeric_Sort'Access) + return File_List; + + + + + function Match + (Input, Pattern : in String) + return Boolean; + + +private + + + type File_List is new Wrapper with record + Entries : Interfaces.C.int := 0; + end record; + + overriding procedure Finalize + (This : in out File_List); + + + fl_path_max : constant Interfaces.C.int; + pragma Import (C, fl_path_max, "fl_path_max"); + + Max_Path_Length : constant Natural := Natural (fl_path_max); + + + pragma Inline (Length); + pragma Inline (Item); + + pragma Inline (Is_Directory); + + pragma Inline (Match); + + +end FLTK.Filenames; + + diff --git a/test.gpr b/test.gpr new file mode 100644 index 0000000..52d4c8a --- /dev/null +++ b/test.gpr @@ -0,0 +1,31 @@ + + +with "fltkada"; + + +project Test is + + + for Languages use ("Ada"); + + + for Source_Dirs use ("test"); + for Object_Dir use "obj"; + for Exec_Dir use "bin"; + for Main use ("compare.adb", "dirlist.adb"); + + + package Builder is + for Executable ("compare.adb") use "compare"; + for Executable ("dirlist.adb") use "dirlist"; + end Builder; + + + package Compiler is + for Default_Switches("Ada") use ("-gnaty4aAbcefhiklM100nprt"); + end Compiler; + + +end Test; + + diff --git a/test/compare.adb b/test/compare.adb new file mode 100644 index 0000000..2273414 --- /dev/null +++ b/test/compare.adb @@ -0,0 +1,45 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Text_IO, + FLTK.Filenames; + + +procedure Compare is + + package TIO renames Ada.Text_IO; + package FFN renames FLTK.Filenames; + + Aardvark : String := "aardvark"; + Zebra : String := "Zebra"; + Two : String := "item_2"; + Ten : String := "item_10"; + Cap_Ten : String := "Item_10"; + +begin + + TIO.Put_Line ("Alphabetic comparison of " & Aardvark & " and " & Zebra & ": " & + FFN.Comparison'Image (FFN.Alpha_Sort (Aardvark, Zebra))); + TIO.Put_Line ("Case insensitive comparison of " & Aardvark & " and " & Zebra & ": " & + FFN.Comparison'Image (FFN.Case_Alpha_Sort (Aardvark, Zebra))); + TIO.New_Line; + + TIO.Put_Line ("Alphabetic comparison of " & Two & " and " & Ten & ": " & + FFN.Comparison'Image (FFN.Alpha_Sort (Two, Ten))); + TIO.Put_Line ("Numeric comparison of " & Two & " and " & Ten & ": " & + FFN.Comparison'Image (FFN.Numeric_Sort (Two, Ten))); + TIO.New_Line; + + TIO.Put_Line ("Numeric comparison of " & Two & " and " & Cap_Ten & ": " & + FFN.Comparison'Image (FFN.Numeric_Sort (Two, Cap_Ten))); + TIO.Put_Line ("Case insensitive comparison of " & Two & " and " & Cap_Ten & ": " & + FFN.Comparison'Image (FFN.Case_Numeric_Sort (Two, Cap_Ten))); + +end Compare; + + diff --git a/test/dirlist.adb b/test/dirlist.adb new file mode 100644 index 0000000..1a07515 --- /dev/null +++ b/test/dirlist.adb @@ -0,0 +1,93 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Characters.Latin_1, + Ada.Command_Line, + Ada.Text_IO, + FLTK.Filenames; + + +procedure Dirlist is + + package Latin renames Ada.Characters.Latin_1; + package ACom renames Ada.Command_Line; + package TIO renames Ada.Text_IO; + package Fil renames FLTK.Filenames; + +begin + + TIO.Put_Line ("Test program for FLTK directory listing function."); + TIO.New_Line; + TIO.Put ("Input: "); + for Index in 1 .. ACom.Argument_Count loop + TIO.Put (ACom.Argument (Index)); + exit when Index = ACom.Argument_Count; + TIO.Put (" "); + end loop; + TIO.New_Line; + TIO.New_Line; + + if ACom.Argument_Count /= 1 then + TIO.Put_Line ("Error: Need exactly one argument to denote a directory to list."); + ACom.Set_Exit_Status (ACom.Failure); + return; + end if; + + declare + Name : Fil.Path_String := Fil.Expand (ACom.Argument (1)); + begin + if not Fil.Is_Directory (Name) then + TIO.Put_Line ("Error: " & Name & " is not a valid directory."); + ACom.Set_Exit_Status (ACom.Failure); + return; + end if; + + declare + The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Alpha_Sort'Access); + begin + TIO.Put_Line ("Alphabetical Sort:"); + for Index in 1 .. The_List.Length loop + TIO.Put_Line (Latin.HT & The_List.Item (Index)); + end loop; + TIO.New_Line; + end; + + declare + The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Alpha_Sort'Access); + begin + TIO.Put_Line ("Case Insensitive Alphabetical Sort:"); + for Index in 1 .. The_List.Length loop + TIO.Put_Line (Latin.HT & The_List.Item (Index)); + end loop; + TIO.New_Line; + end; + + declare + The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Numeric_Sort'Access); + begin + TIO.Put_Line ("Numeric Sort:"); + for Index in 1 .. The_List.Length loop + TIO.Put_Line (Latin.HT & The_List.Item (Index)); + end loop; + TIO.New_Line; + end; + + declare + The_List : Fil.File_List := Fil.Get_Listing (Name, Fil.Case_Numeric_Sort'Access); + begin + TIO.Put_Line ("Case Insensitive Numeric Sort:"); + for Index in 1 .. The_List.Length loop + TIO.Put_Line (Latin.HT & The_List.Item (Index)); + end loop; + TIO.New_Line; + end; + end; + +end Dirlist; + + |