/*
* Copyright (c) 2005-2009, 2013 by the gtk2-perl team (see the file AUTHORS)
*
* Licensed under the LGPL, see LICENSE file for more information.
*
* $Id$
*/
#include "gperl.h"
#include "gperl-gtypes.h"
/* ------------------------------------------------------------------------- */
/* This hash table is used to store option groups that have been handed to
* GOptionContext.
*/
static GHashTable *transferred_groups = NULL;
static GOptionGroup *
gperl_option_group_transfer (GOptionGroup *group)
{
if (!transferred_groups)
transferred_groups =
g_hash_table_new (g_direct_hash, g_direct_equal);
g_hash_table_insert (transferred_groups, group, group);
return group;
}
/* ------------------------------------------------------------------------- */
/* Define custom types for GOptionContext, GOptionGroup, GOptionFlags, and
* GOptionArg since glib doesn't provide them.
*/
static gpointer
no_copy_for_you (gpointer boxed)
{
croak ("copying Glib::OptionContext and Glib::OptionGroup isn't supported");
return boxed;
}
/* glib assumes ownership of option groups it gets, and there's no copy
* function. So we need a custom free function here that checks if the group
* was transferred to glib already before freeing it.
*/
static void
gperl_option_group_free (GOptionGroup *group)
{
if (!g_hash_table_lookup (transferred_groups, group))
g_option_group_free (group);
}
GType
gperl_option_context_get_type (void)
{
static GType t = 0;
if (!t)
t = g_boxed_type_register_static ("GOptionContext",
(GBoxedCopyFunc) no_copy_for_you,
(GBoxedFreeFunc) g_option_context_free);
return t;
}
GType
gperl_option_group_get_type (void)
{
static GType t = 0;
if (!t)
t = g_boxed_type_register_static ("GOptionGroup",
(GBoxedCopyFunc) no_copy_for_you,
(GBoxedFreeFunc) gperl_option_group_free);
return t;
}
/* ------------------------------------------------------------------------- */
#if 0
static SV *
newSVGOptionFlags (GOptionFlags flags)
{
return gperl_convert_back_flags (GPERL_TYPE_OPTION_FLAGS, flags);
}
#endif
static GOptionFlags
SvGOptionFlags (SV *sv)
{
return gperl_convert_flags (GPERL_TYPE_OPTION_FLAGS, sv);
}
/* ------------------------------------------------------------------------- */
#if 0
static SV *
newSVGOptionArg (GOptionArg arg)
{
return gperl_convert_back_enum (GPERL_TYPE_OPTION_ARG, arg);
}
#endif
static GOptionArg
SvGOptionArg (SV *sv)
{
return gperl_convert_enum (GPERL_TYPE_OPTION_ARG, sv);
}
/* ------------------------------------------------------------------------- */
typedef struct {
GOptionArg arg;
gpointer arg_data;
} GPerlArgInfo;
static GPerlArgInfo *
gperl_arg_info_new (GOptionArg arg, gpointer arg_data)
{
GPerlArgInfo *info = g_new0 (GPerlArgInfo, 1);
info->arg = arg;
info->arg_data = arg_data;
return info;
}
static void
gperl_arg_info_destroy (GPerlArgInfo *info)
{
g_free (info->arg_data); /* NULL-safe */
g_free (info);
}
typedef struct {
GHashTable *scalar_to_info;
GSList *allocated_strings;
} GPerlArgInfoTable;
static GPerlArgInfoTable *
gperl_arg_info_table_new (void)
{
GPerlArgInfoTable *table = g_new0 (GPerlArgInfoTable, 1);
table->scalar_to_info =
g_hash_table_new_full (g_direct_hash,
g_direct_equal,
NULL,
(GDestroyNotify) gperl_arg_info_destroy);
table->allocated_strings = NULL;
return table;
}
static void
gperl_arg_info_table_destroy (GPerlArgInfoTable *table)
{
g_hash_table_destroy (table->scalar_to_info);
/* These are NULL-safe. */
g_slist_foreach (table->allocated_strings, (GFunc) g_free, NULL);
g_slist_free (table->allocated_strings);
g_free (table);
}
/* ------------------------------------------------------------------------- */
#define INSTALL_POINTER(type) \
{ \
type *pointer = g_new0 (type, 1); \
g_hash_table_insert (scalar_to_info, \
ref, \
gperl_arg_info_new (entry->arg, pointer)); \
entry->arg_data = pointer; \
}
static void
handle_arg_data (GOptionEntry *entry, SV *ref, GHashTable *scalar_to_info)
{
if (!gperl_sv_is_ref (ref))
croak ("encountered non-reference variable for the arg_value "
"field");
switch (entry->arg) {
case G_OPTION_ARG_NONE:
INSTALL_POINTER (gboolean);
break;
case G_OPTION_ARG_STRING:
case G_OPTION_ARG_FILENAME:
INSTALL_POINTER (gchar *);
break;
case G_OPTION_ARG_INT:
INSTALL_POINTER (gint);
break;
case G_OPTION_ARG_CALLBACK:
croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered");
break;
case G_OPTION_ARG_STRING_ARRAY:
case G_OPTION_ARG_FILENAME_ARRAY:
INSTALL_POINTER (gchar **);
break;
#if GLIB_CHECK_VERSION (2, 12, 0)
case G_OPTION_ARG_DOUBLE:
INSTALL_POINTER (gdouble);
break;
case G_OPTION_ARG_INT64:
INSTALL_POINTER (gint64);
break;
#endif
}
}
static gchar *
copy_string (gchar *src, GPerlArgInfoTable *table)
{
gchar *result;
if (!src)
return NULL;
result = g_strdup (src);
table->allocated_strings =
g_slist_prepend (table->allocated_strings, result);
return result;
}
static GOptionEntry *
sv_to_option_entry (SV *sv, GPerlArgInfoTable *table)
{
SV *long_name = NULL,
*short_name = NULL,
*flags = NULL,
*description = NULL,
*arg_description = NULL,
*arg_type = NULL,
*arg_value = NULL;
GOptionEntry *entry;
if (!gperl_sv_is_hash_ref (sv) && !gperl_sv_is_array_ref (sv))
croak ("an option entry must be either a hash or an array "
"reference");
if (gperl_sv_is_hash_ref (sv)) {
HV *hv = (HV *) SvRV (sv);
SV **value;
value = hv_fetch (hv, "long_name", 9, 0);
if (value) long_name = *value;
value = hv_fetch (hv, "short_name", 10, 0);
if (value) short_name = *value;
value = hv_fetch (hv, "flags", 5, 0);
if (value) flags = *value;
value = hv_fetch (hv, "description", 11, 0);
if (value) description = *value;
value = hv_fetch (hv, "arg_description", 15, 0);
if (value) arg_description = *value;
value = hv_fetch (hv, "arg_type", 8, 0);
if (value) arg_type = *value;
value = hv_fetch (hv, "arg_value", 9, 0);
if (value) arg_value = *value;
} else {
AV *av = (AV *) SvRV (sv);
SV **value;
if (4 != av_len (av) + 1)
croak ("an option entry array reference must contain "
"four values: long_name, short_name, arg_type, "
"and arg_value");
value = av_fetch (av, 0, 0);
if (value) long_name = *value;
value = av_fetch (av, 1, 0);
if (value) short_name = *value;
value = av_fetch (av, 2, 0);
if (value) arg_type = *value;
value = av_fetch (av, 3, 0);
if (value) arg_value = *value;
}
if (!gperl_sv_is_defined (long_name) ||
!gperl_sv_is_defined (arg_type) ||
!gperl_sv_is_defined (arg_value))
croak ("in an option entry, the fields long_name, arg_type, and "
"arg_value must be specified");
entry = gperl_alloc_temp (sizeof (GOptionEntry));
entry->long_name = copy_string (SvGChar (long_name), table);
entry->arg = SvGOptionArg (arg_type);
entry->arg_data = NULL;
handle_arg_data (entry, arg_value, table->scalar_to_info);
entry->short_name = gperl_sv_is_defined (short_name)
? (SvGChar (short_name))[0]
: 0;
entry->flags = gperl_sv_is_defined (flags)
? SvGOptionFlags (flags)
: 0;
entry->description = gperl_sv_is_defined (description)
? copy_string (SvGChar (description), table)
: NULL;
entry->arg_description = gperl_sv_is_defined (arg_description)
? copy_string (SvGChar (arg_description), table)
: NULL;
return entry;
}
static GOptionEntry *
sv_to_option_entries (SV *sv, GPerlArgInfoTable *table)
{
GOptionEntry *entries;
AV *av;
int length, i;
SV **value;
if (!gperl_sv_is_array_ref (sv))
croak ("option entries must be an array reference containing hash references");
av = (AV *) SvRV (sv);
length = av_len (av) + 1;
/* Allocating length + 1 entries here because the list is supposed to
* be NULL-terminated. */
entries = gperl_alloc_temp (sizeof (GOptionEntry) * (length + 1));
for (i = 0; i < length; i++) {
value = av_fetch (av, i, 0);
if (value && gperl_sv_is_defined (*value))
entries[i] = *(sv_to_option_entry (*value, table));
}
return entries;
}
/* ------------------------------------------------------------------------- */
static gchar **
strings_from_sv (SV *sv)
{
AV *av;
gint n_strings, i;
gchar **result;
if (!gperl_sv_is_array_ref (sv))
return NULL;
av = (AV *) SvRV (sv);
n_strings = av_len (av) + 1;
if (n_strings <= 0)
return NULL;
/* NULL-terminated */
result = gperl_alloc_temp (sizeof (gchar *) * (n_strings + 1));
for (i = 0; i < n_strings; i++) {
SV **string_sv = av_fetch (av, i, 0);
result[i] = string_sv ? SvGChar (*string_sv) : NULL;
}
return result;
}
static gchar **
filenames_from_sv (SV *sv)
{
AV *av;
gint n_filenames, i;
gchar **result;
if (!gperl_sv_is_array_ref (sv))
return NULL;
av = (AV *) SvRV (sv);
n_filenames = av_len (av) + 1;
if (n_filenames <= 0)
return NULL;
/* NULL-terminated */
result = gperl_alloc_temp (sizeof (gchar *) * (n_filenames + 1));
for (i = 0; i < n_filenames; i++) {
SV **string_sv = av_fetch (av, i, 0);
result[i] = string_sv ? SvPV_nolen (*string_sv) : NULL;
}
return result;
}
#define INITIALIZE_POINTER(type, converter) \
{ \
SV *sv = SvRV (ref); \
if (gperl_sv_is_defined (sv)) \
*((type *) info->arg_data) = converter (sv); \
}
static void
initialize_scalar (gpointer key,
gpointer value,
gpointer data)
{
SV *ref = key;
GPerlArgInfo *info = value;
PERL_UNUSED_VAR (data);
switch (info->arg) {
case G_OPTION_ARG_NONE:
INITIALIZE_POINTER (gboolean, sv_2bool);
break;
case G_OPTION_ARG_STRING:
INITIALIZE_POINTER (gchar *, SvGChar);
break;
case G_OPTION_ARG_INT:
INITIALIZE_POINTER (gint, SvIV);
break;
case G_OPTION_ARG_CALLBACK:
croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered");
break;
case G_OPTION_ARG_FILENAME:
/* FIXME: Is this the correct converter? */
INITIALIZE_POINTER (gchar *, SvPV_nolen);
break;
case G_OPTION_ARG_STRING_ARRAY:
INITIALIZE_POINTER (gchar **, strings_from_sv);
break;
case G_OPTION_ARG_FILENAME_ARRAY:
INITIALIZE_POINTER (gchar **, filenames_from_sv);
break;
#if GLIB_CHECK_VERSION (2, 12, 0)
case G_OPTION_ARG_DOUBLE:
INITIALIZE_POINTER (gdouble, SvNV);
break;
case G_OPTION_ARG_INT64:
INITIALIZE_POINTER (gint64, SvGInt64);
break;
#endif
}
}
static gboolean
initialize_scalars (GOptionContext *context,
GOptionGroup *group,
gpointer data,
GError **error)
{
GPerlArgInfoTable *table = data;
PERL_UNUSED_VAR (context);
PERL_UNUSED_VAR (group);
PERL_UNUSED_VAR (error);
g_hash_table_foreach (table->scalar_to_info, initialize_scalar, NULL);
return TRUE;
}
/* ------------------------------------------------------------------------- */
static SV *
sv_from_strings (gchar **strings)
{
AV *av;
gint i;
if (!strings)
return &PL_sv_undef;
av = newAV ();
for (i = 0; strings[i] != NULL; i++) {
av_push (av, newSVGChar (strings[i]));
}
return newRV_noinc ((SV *) av);
}
static SV *
sv_from_filenames (gchar **filenames)
{
AV *av;
gint i;
if (!filenames)
return &PL_sv_undef;
av = newAV ();
for (i = 0; filenames[i] != NULL; i++) {
/* FIXME: Is this the correct converter? */
av_push (av, newSVpv (filenames[i], 0));
}
return newRV_noinc ((SV *) av);
}
#define READ_POINTER(type) (*((type *) info->arg_data))
static void
fill_in_scalar (gpointer key,
gpointer value,
gpointer data)
{
SV *ref = key;
GPerlArgInfo *info = value;
SV *sv = SvRV (ref);
PERL_UNUSED_VAR (data);
switch (info->arg) {
case G_OPTION_ARG_NONE:
sv_setsv (sv, boolSV (READ_POINTER (gboolean)));
break;
case G_OPTION_ARG_STRING:
sv_setpv (sv, READ_POINTER (gchar *));
SvUTF8_on (sv);
break;
case G_OPTION_ARG_INT:
sv_setiv (sv, READ_POINTER (gint));
break;
case G_OPTION_ARG_CALLBACK:
croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered");
break;
case G_OPTION_ARG_FILENAME:
/* FIXME: Is this the correct converter? */
sv_setpv (sv, READ_POINTER (gchar *));
break;
case G_OPTION_ARG_STRING_ARRAY:
sv_setsv (sv, sv_from_strings (READ_POINTER (gchar **)));
break;
case G_OPTION_ARG_FILENAME_ARRAY:
sv_setsv (sv, sv_from_filenames (READ_POINTER (gchar **)));
break;
#if GLIB_CHECK_VERSION (2, 12, 0)
case G_OPTION_ARG_DOUBLE:
sv_setnv (sv, READ_POINTER (gdouble));
break;
case G_OPTION_ARG_INT64:
sv_setsv (sv, newSVGInt64 (READ_POINTER (gint64)));
break;
#endif
}
}
static gboolean
fill_in_scalars (GOptionContext *context,
GOptionGroup *group,
gpointer data,
GError **error)
{
GPerlArgInfoTable *table = data;
PERL_UNUSED_VAR (context);
PERL_UNUSED_VAR (group);
PERL_UNUSED_VAR (error);
g_hash_table_foreach (table->scalar_to_info, fill_in_scalar, NULL);
return TRUE;
}
/* ------------------------------------------------------------------------- */
static GPerlCallback *
gperl_translate_func_create (SV *func, SV *data)
{
GType param_types [1];
param_types[0] = G_TYPE_STRING;
return gperl_callback_new (func, data, G_N_ELEMENTS (param_types),
param_types, G_TYPE_STRING);
}
static const gchar *
gperl_translate_func (const gchar *str, gpointer data)
{
GPerlCallback *callback = (GPerlCallback *) data;
GValue value = {0,};
const gchar *retval;
/* FIXME: This leaks but I've no idea how to make sure the string
* survives. */
g_value_init (&value, callback->return_type);
gperl_callback_invoke (callback, &value, str);
retval = g_value_dup_string (&value);
g_value_unset (&value);
return retval;
}
/* ------------------------------------------------------------------------- */
MODULE = Glib::Option PACKAGE = Glib::OptionContext PREFIX = g_option_context_
BOOT:
gperl_register_boxed (GPERL_TYPE_OPTION_CONTEXT, "Glib::OptionContext", NULL);
gperl_register_boxed (GPERL_TYPE_OPTION_GROUP, "Glib::OptionGroup", NULL);
gperl_register_fundamental (GPERL_TYPE_OPTION_ARG, "Glib::OptionArg");
gperl_register_fundamental (GPERL_TYPE_OPTION_FLAGS, "Glib::OptionFlags");
=for position SYNOPSIS
=head1 SYNOPSIS
my ($verbose, $source, $filenames) = ('', undef, []);
my $entries = [
{ long_name => 'verbose',
short_name => 'v',
arg_type => 'none',
arg_value => \$verbose,
description => 'be verbose' },
{ long_name => 'source',
short_name => 's',
arg_type => 'string',
arg_value => \$source,
description => 'set the source',
arg_description => 'source' },
[ 'filenames', 'f', 'filename-array', \$filenames ],
];
my $context = Glib::OptionContext->new ('- urgsify your life');
$context->add_main_entries ($entries, 'C');
$context->parse ();
# $verbose, $source, and $filenames are now updated according to the
# command line options given
=cut
## GOptionContext * g_option_context_new (const gchar *parameter_string);
GOptionContext_own *
g_option_context_new (class, parameter_string);
const gchar *parameter_string
C_ARGS:
parameter_string
void g_option_context_set_help_enabled (GOptionContext *context, gboolean help_enabled);
gboolean g_option_context_get_help_enabled (GOptionContext *context);
void g_option_context_set_ignore_unknown_options (GOptionContext *context, gboolean ignore_unknown);
gboolean g_option_context_get_ignore_unknown_options (GOptionContext *context);
# void g_option_context_add_main_entries (GOptionContext *context, const GOptionEntry *entries, const gchar *translation_domain);
=for signature
=arg entries reference to an array of option entries
=cut
void
g_option_context_add_main_entries (GOptionContext *context, SV *entries, const gchar *translation_domain)
PREINIT:
GPerlArgInfoTable *table;
GOptionGroup *group;
GOptionEntry *real_entries;
CODE:
table = gperl_arg_info_table_new ();
group = g_option_group_new (NULL, NULL, NULL,
table,
(GDestroyNotify) gperl_arg_info_table_destroy);
g_option_group_set_parse_hooks (group, initialize_scalars,
fill_in_scalars);
real_entries = sv_to_option_entries (entries, table);
if (real_entries)
g_option_group_add_entries (group, real_entries);
g_option_group_set_translation_domain (group, translation_domain);
/* context assumes ownership of group */
g_option_context_set_main_group (context, group);
## gboolean g_option_context_parse (GOptionContext *context, gint *argc, gchar ***argv, GError **error);
=for apidoc __gerror__
This method works directly on I<@ARGV>.
=cut
gboolean
g_option_context_parse (context)
GOptionContext *context
PREINIT:
GPerlArgv *pargv;
GError *error = NULL;
CODE:
pargv = gperl_argv_new ();
RETVAL = g_option_context_parse (context, &pargv->argc, &pargv->argv, &error);
if (error) {
gperl_argv_free (pargv);
gperl_croak_gerror (NULL, error);
}
gperl_argv_update (pargv);
gperl_argv_free (pargv);
OUTPUT:
RETVAL
# Groups that belong to a context will be destroyed when that context goes
# away, so we need to mark the group to ensure it doesn't get freed by our
# boxed wrappers.
## void g_option_context_add_group (GOptionContext *context, GOptionGroup *group);
void
g_option_context_add_group (context, group)
GOptionContext *context
GOptionGroup *group
C_ARGS:
context, gperl_option_group_transfer (group)
## void g_option_context_set_main_group (GOptionContext *context, GOptionGroup *group);
void
g_option_context_set_main_group (context, group);
GOptionContext *context
GOptionGroup *group
C_ARGS:
context, gperl_option_group_transfer (group)
GOptionGroup * g_option_context_get_main_group (GOptionContext *context);
# --------------------------------------------------------------------------- #
MODULE = Glib::Option PACKAGE = Glib::OptionGroup PREFIX = g_option_group_
=for enum Glib::OptionFlags
=cut
=for enum Glib::OptionArg
=cut
## GOptionGroup * g_option_group_new (const gchar *name, const gchar *description, const gchar *help_description, gpointer user_data, GDestroyNotify destroy);
## void g_option_group_add_entries (GOptionGroup *group, const GOptionEntry *entries);
## void g_option_group_set_parse_hooks (GOptionGroup *group, GOptionParseFunc pre_parse_func, GOptionParseFunc post_parse_func);
## void g_option_group_set_error_hook (GOptionGroup *group, GOptionErrorFunc error_func);
=for apidoc
=for signature optiongroup = Glib::OptionGroup->new (key => value, ...)
=for arg ... (__hide__)
Creates a new option group from the given key-value pairs. The valid keys are
name, description, help_description, and entries. The first three specify
strings while the last one, entries, specifies an array reference of option
entries. Example:
my $group = Glib::OptionGroup->new (
name => 'urgs',
description => 'Urgs Urgs Urgs',
help_description => 'Help with Urgs',
entries => \@entries);
An option entry is a hash reference like this:
{ long_name => 'verbose',
short_name => 'v',
flags => [qw/reverse hidden in-main/],
arg_type => 'none',
arg_value => \$verbose,
description => 'verbose desc.',
arg_description => 'verbose arg desc.' }
Of those keys only long_name, arg_type, and arg_value are required. So this is
a valid option entry too:
{ long_name => 'package-names',
arg_type => 'string-array',
arg_value => \$package_names }
For convenience, option entries can also be specified as array references
containing long_name, short_name, arg_type, and arg_value:
[ 'filenames', 'f', 'filename-array', \$filenames ]
If you don't want an option to have a short name, specify undef for it:
[ 'filenames', undef, 'filename-array', \$filenames ]
=cut
GOptionGroup_own *
g_option_group_new (class, ...)
PREINIT:
int i;
gchar *name = NULL;
gchar *description = NULL;
gchar *help_description = NULL;
SV *entries = NULL;
GPerlArgInfoTable *table;
GOptionEntry *real_entries = NULL;
CODE:
if ((items - 1) % 2 != 0)
croak ("even number of arguments expected: key => value, ...");
for (i = 1; i < items; i += 2) {
char *key = SvPV_nolen (ST (i));
SV *value = ST (i + 1);
if (strEQ (key, "name"))
name = SvGChar (value);
else if (strEQ (key, "description"))
description = SvGChar (value);
else if (strEQ (key, "help_description"))
help_description = SvGChar (value);
else if (strEQ (key, "entries"))
entries = value;
else
warn ("unknown key `%s´ encountered; ignoring", key);
}
table = gperl_arg_info_table_new ();
if (entries)
real_entries = sv_to_option_entries (entries, table);
RETVAL = g_option_group_new (name,
description,
help_description,
table,
(GDestroyNotify) gperl_arg_info_table_destroy);
g_option_group_set_parse_hooks (RETVAL, initialize_scalars, fill_in_scalars);
if (real_entries)
g_option_group_add_entries (RETVAL, real_entries);
OUTPUT:
RETVAL
## void g_option_group_set_translate_func (GOptionGroup *group, GTranslateFunc func, gpointer data, GDestroyNotify destroy_notify);
void
g_option_group_set_translate_func (group, func, data=NULL);
GOptionGroup *group
SV *func
SV *data
PREINIT:
GPerlCallback *callback;
CODE:
callback = gperl_translate_func_create (func, data);
g_option_group_set_translate_func (group,
gperl_translate_func,
callback,
(GDestroyNotify)
gperl_callback_destroy);
void g_option_group_set_translation_domain (GOptionGroup *group, const gchar *domain);