Index: /trunk/mt-wizard.cgi =================================================================== --- /trunk/mt-wizard.cgi (revision 1174) +++ /trunk/mt-wizard.cgi (revision 3531) @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# Movable Type (r) Open Source (C) 2001-2009 Six Apart, Ltd. # This program is distributed under the terms of the # GNU General Public License, version 2. Index: /trunk/mt-atom.cgi =================================================================== --- /trunk/mt-atom.cgi (revision 1174) +++ /trunk/mt-atom.cgi (revision 3531) @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# Movable Type (r) Open Source (C) 2001-2009 Six Apart, Ltd. # This program is distributed under the terms of the # GNU General Public License, version 2. Index: /trunk/mt.cgi =================================================================== --- /trunk/mt.cgi (revision 1174) +++ /trunk/mt.cgi (revision 3531) @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd. +# Movable Type (r) Open Source (C) 2001-2009 Six Apart, Ltd. # This program is distributed under the terms of the # GNU General Public License, version 2. Index: /trunk/mt-feed.cgi =================================================================== --- /trunk/mt-feed.cgi (revision 1174) +++ /trunk/mt-feed.cgi (revision 3531) @@ -1,5 +1,5 @@ #!/usr/bin/perl -w -# Movable Type (r) Open Source (C) 2005-2008 Six Apart, Ltd. +# Movable Type (r) Open Source (C) 2005-2009 Six Apart, Ltd. # This program is distributed under the terms of the # GNU General Public License, version 2. Index: /trunk/php/lib/function.mtentrystatus.php =================================================================== --- /trunk/php/lib/function.mtentrystatus.php (revision 1174) +++ /trunk/php/lib/function.mtentrystatus.php (revision 3531) @@ -1,4 +1,4 @@ stash('all_tag_count'); - if (!$ntags) return 1; - $min = $ctx->stash('tag_min_count'); $max = $ctx->stash('tag_max_count'); + if (!$ntags or !$min or !$max) { + $class = $ctx->stash('class_type'); + if (isset($class)) { + if ('entry' == $class or 'page' == $class) { + # for Entry/Page + $class = strtolower($ctx->stash('class_type')); + $tags = $ctx->mt->db->fetch_entry_tags(array('blog_id' => $blog_id, 'class' => $class)); + } elseif ('asset' == $class) { + # for Asset + $tags = $ctx->mt->db->fetch_asset_tags(array('blog_id' => $blog_id)); + } else { + return ''; + } + } + if (!is_array($tags)) $tags = array(); + + $min = 0; $max = 0; + $ntags = 0; + $tagnames = ''; + foreach ($tags as $_tag) { + $count = $_tag['tag_count']; + if ($count > $max) $max = $count; + if ($count < $min or $min == 0) $min = $count; + $ntags += $count; + } + $ctx->stash('tag_min_count', $min); + $ctx->stash('tag_max_count', $max); + $ctx->stash('all_tag_count', $ntags); + } + $factor; Index: /trunk/php/lib/function.mtassetrank.php =================================================================== --- /trunk/php/lib/function.mtassetrank.php (revision 2786) +++ /trunk/php/lib/function.mtassetrank.php (revision 3531) @@ -1,4 +1,4 @@ get_key()] = $provider; $provider = new TypeKeyCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new GoogleCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new YahooCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new AIMCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new WordPressCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new YahooJPCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new LivedoorCommenterAuth(); +$_commenter_auths[$provider->get_key()] = $provider; +$provider = new HatenaCommenterAuth(); $_commenter_auths[$provider->get_key()] = $provider; @@ -100,8 +114,113 @@ } function get_logo() { - return 'images/comment/signin_typekey.png'; - } - function get_logo_small() { - return 'images/comment/typekey_logo.png'; + return 'images/comment/signin_typepad.png'; + } + function get_logo_small() { + return 'images/comment/typepad_logo.png'; + } +} + +class GoogleCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'Google'; + } + function get_label() { + return 'Google Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/google.png'; + } + function get_logo_small() { + return 'images/comment/google_logo.png'; + } +} + +class YahooCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'Yahoo'; + } + function get_label() { + return 'Yahoo Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/yahoo.png'; + } + function get_logo_small() { + return 'images/comment/favicon_yahoo.png'; + } +} + +class AIMCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'AIM'; + } + function get_label() { + return 'AIM Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/aim.png'; + } + function get_logo_small() { + return 'images/comment/aim_logo.png'; + } +} + +class WordPressCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'WordPress'; + } + function get_label() { + return 'WordPress Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/wordpress.png'; + } + function get_logo_small() { + return 'images/comment/wordpress_logo.png'; + } +} + +class YahooJPCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'YahooJP'; + } + function get_label() { + return 'Yahoo Japan Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/yahoo.png'; + } + function get_logo_small() { + return 'images/comment/favicon_yahoo.png'; + } +} + +class LivedoorCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'livedoor'; + } + function get_label() { + return 'livedoor Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/signin_livedoor.png'; + } + function get_logo_small() { + return 'images/comment/livedoor_logo.png'; + } +} + +class HatenaCommenterAuth extends BaseCommenterAuthProvider { + function get_key() { + return 'Hatena'; + } + function get_label() { + return 'Hatena Commenter Authenticator'; + } + function get_logo() { + return 'images/comment/signin_hatena.png'; + } + function get_logo_small() { + return 'images/comment/hatena_logo.png'; } } Index: /trunk/php/lib/function.mthttpcontenttype.php =================================================================== --- /trunk/php/lib/function.mthttpcontenttype.php (revision 1174) +++ /trunk/php/lib/function.mthttpcontenttype.php (revision 3531) @@ -1,4 +1,4 @@ mt->config('CommenterRegistration') + $blog = $ctx->stash('blog'); + return $registration['Allow'] && ($blog && $blog['blog_allow_commenter_regist']) +} +?> Index: /trunk/php/lib/block.mtifregistrationnotrequired.php =================================================================== --- /trunk/php/lib/block.mtifregistrationnotrequired.php (revision 1174) +++ /trunk/php/lib/block.mtifregistrationnotrequired.php (revision 3531) @@ -1,4 +1,4 @@ src_w; @@ -41,4 +41,16 @@ $thumb_w_name = $thumb_w; $thumb_h_name = $thumb_h; + } elseif ($square) { + if ($width > 0) { + $thumb_w = $width; + $thumb_h = $width; + $thumb_w_name = $width; + $thumb_h_name = $width; + } else { + $thumb_w = $height; + $thumb_h = $height; + $thumb_w_name = $height; + $thumb_h_name = $height; + } } elseif ($width > 0 || $height > 0) { $thumb_w_name = 'auto'; @@ -94,5 +106,5 @@ # Load or generate a thumbnail. - function get_thumbnail (&$dest, &$width, &$height, $id, $scale = 0, $format = '%f-thumb-%wx%h-%i%x', $dest_type = 'auto') { + function get_thumbnail (&$dest, &$width, &$height, $id, $scale = 0, $format = '%f-thumb-%wx%h-%i%x', $dest_type = 'auto', $square = false) { if (empty($this->src_file)) return false; if (!file_exists($this->src_file)) return false; @@ -126,5 +138,5 @@ # Calculate thumbnail size - list ($thumb_w, $thumb_h, $thumb_w_name, $thumb_h_name) = $this->_calculate_size($width, $height, $scale); + list ($thumb_w, $thumb_h, $thumb_w_name, $thumb_h_name) = $this->_calculate_size($width, $height, $scale, $square); $width = $thumb_w; $height = $thumb_h; @@ -134,5 +146,4 @@ $dest = $this->_make_dest_name($thumb_w_name, $thumb_h_name, $format, $dest_type, $id); } - # Generate if(!file_exists($dest)) { @@ -145,8 +156,25 @@ } + # if square modifier is enable, crop & resize + $src_x = 0; + $src_y = 0; + $target_w = $this->src_w; + $target_h = $this->src_h; + if ($square) { + if ($this->src_w > $this->src_h) { + $src_x = (int)($this->src_w - $this->src_h) / 2; + $src_y = 0; + $target_w = $this->src_h; + } else { + $src_x = 0; + $src_y = (int)($this->src_h - $this->src_w) / 2; + $target_h = $this->src_w; + } + } + # Create thumbnail $dst_img = imagecreatetruecolor ( $thumb_w, $thumb_h ); - $result = imagecopyresampled ( $dst_img, $src_img, 0, 0, 0, 0, - $thumb_w, $thumb_h, $this->src_w, $this->src_h); + $result = imagecopyresampled ( $dst_img, $src_img, 0, 0, $src_x, $src_y, + $thumb_w, $thumb_h, $target_w, $target_h); $output = $this->src_type; Index: /trunk/php/lib/function.mtcommentauthor.php =================================================================== --- /trunk/php/lib/function.mtcommentauthor.php (revision 2503) +++ /trunk/php/lib/function.mtcommentauthor.php (revision 3531) @@ -1,4 +1,4 @@ localize($localvars); @@ -29,4 +29,12 @@ if (!isset($args['need_entry'])) { $args['need_entry'] = 1; + } + if (isset($args['scoring_to'])) { + $args['_scoring_to_obj'] = $ctx->stash($args['scoring_to']); + if (is_null($args['_scoring_to_obj'])) { + $ctx->restore($localvars); + $repeat = false; + return; + } } $authors = $ctx->mt->db->fetch_authors($args); Index: /trunk/php/lib/modifier.sprintf.php =================================================================== --- /trunk/php/lib/modifier.sprintf.php (revision 1174) +++ /trunk/php/lib/modifier.sprintf.php (revision 3531) @@ -1,4 +1,4 @@ 'Error: el conjunto de widgets [_1] está vacío', + 'Error compiling widgetset [_1]' => 'Error compilando el conjunto de widgets [_1]', + +## php/lib/function.mtvar.php + 'You used a [_1] tag without a valid name attribute.' => 'Usó la etiqueta [_1] sin un nombre de atributo válido.', + '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' no es una función válida para un hash.', + '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' no es una función válida para un array.', + '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] es ilegal.', + ## php/lib/function.mtassettype.php 'image' => 'Imagen', @@ -18,19 +28,12 @@ 'Video' => 'Vídeo', -## php/lib/function.mtvar.php - 'You used a [_1] tag without a valid name attribute.' => 'Usó la etiqueta [_1] sin un nombre de atributo válido.', - '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' no es una función válida para un hash.', - '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' no es una función válida para un array.', - '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] es ilegal.', - -## php/lib/function.mtwidgetmanager.php - 'Error: widgetset [_1] is empty.' => 'Error: el conjunto de widgets [_1] está vacío', - 'Error compiling widgetset [_1]' => 'Error compilando el conjunto de widgets [_1]', - ## php/lib/thumbnail_lib.php - 'GD support has not been available. Please install GD support.' => 'No tiene soporte de GD. Por favor, instale GD.', # Translate - New + 'GD support has not been available. Please install GD support.' => 'No tiene soporte de GD. Por favor, instale GD.', ## php/lib/function.mtcommentauthor.php 'Anonymous' => 'Anónimo', + +## php/lib/MTUtil.php + 'userpic-[_1]-%wx%h%x' => 'avatar-[_1]-%wx%h%x', ## php/lib/archive_lib.php @@ -52,13 +55,13 @@ 'Category Weekly' => 'Categorías semanales', -## php/lib/block.mtsethashvar.php - ## php/lib/block.mtif.php ## php/lib/function.mtremotesigninlink.php - 'TypeKey authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'La autentificación en TypeKey no está habilitada en este blog. No se puede usar MTRemoteSignInLink.', + 'TypePad authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'La autentificación de TypePad no está habilitada en este blog. No se puede usar MTRemoteSignInLink.', ## php/lib/block.mtauthorhaspage.php 'No author available' => 'Ningún autor disponible', + +## php/lib/block.mtsethashvar.php ## php/lib/block.mtauthorhasentry.php @@ -67,12 +70,9 @@ '[_1] [_2]' => '[_1] [_2]', +## php/lib/function.mtcommentauthorlink.php + ## php/lib/captcha_lib.php 'Captcha' => 'Captcha', 'Type the characters you see in the picture above.' => 'Introduzca los caracteres que ve en la imagen de arriba.', - -## php/lib/function.mtcommentauthorlink.php - -## php/lib/MTUtil.php - 'userpic-[_1]-%wx%h%x' => 'avatar-[_1]-%wx%h%x', ## php/lib/function.mtsetvar.php @@ -91,11 +91,11 @@ ## php/lib/function.mtauthordisplayname.php -## php/lib/function.mtcommentreplytolink.php - 'Reply' => 'Responder', - ## php/lib/function.mtentryclasslabel.php 'page' => 'página', 'entry' => 'entrada', 'Entry' => 'Entrada', + +## php/lib/function.mtcommentreplytolink.php + 'Reply' => 'Responder', ## php/mt.php.pre Index: /trunk/php/lib/function.mtpageauthorlink.php =================================================================== --- /trunk/php/lib/function.mtpageauthorlink.php (revision 1174) +++ /trunk/php/lib/function.mtpageauthorlink.php (revision 3531) @@ -1,4 +1,4 @@ _hdlr_if($args, $content, $ctx, $repeat, $ctx->mt->config('ExternalUserManagement')); +} +?> Index: /trunk/php/lib/function.mtauthorname.php =================================================================== --- /trunk/php/lib/function.mtauthorname.php (revision 2356) +++ /trunk/php/lib/function.mtauthorname.php (revision 3531) @@ -1,4 +1,4 @@ 'Erreur: le groupe de widget [_1] est vide.', + 'Error compiling widgetset [_1]' => 'Erreur de compilation du groupe de widget [_1]', + +## php/lib/function.mtvar.php + 'You used a [_1] tag without a valid name attribute.' => 'Vous avez utilisé un tag [_1] sans un attribut de nom valide', + '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' n\'est pas une fonction valide pour un hash', + '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' n\'est pas une fonction valide pour un tableau', + '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] est illégal.', + ## php/lib/function.mtassettype.php 'image' => 'image', @@ -18,19 +28,12 @@ 'Video' => 'Vidéo', -## php/lib/function.mtvar.php - 'You used a [_1] tag without a valid name attribute.' => 'Vous avez utilisé un tag [_1] sans un attribut de nom valide', - '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' n\'est pas une fonction valide pour un hash', - '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' n\'est pas une fonction valide pour un tableau', - '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] est illégal.', - -## php/lib/function.mtwidgetmanager.php - 'Error: widgetset [_1] is empty.' => 'Erreur: le groupe de widget [_1] est vide.', - 'Error compiling widgetset [_1]' => 'Erreur de compilation du groupe de widget [_1]', - ## php/lib/thumbnail_lib.php - 'GD support has not been available. Please install GD support.' => 'Le support GP n\'est pas disponible. Veuillez installer le support GD.', # Translate - New + 'GD support has not been available. Please install GD support.' => 'Le support GP n\'est pas disponible. Veuillez installer le support GD.', ## php/lib/function.mtcommentauthor.php 'Anonymous' => 'Anonyme', + +## php/lib/MTUtil.php + 'userpic-[_1]-%wx%h%x' => 'userpic-[_1]-%wx%h%x', ## php/lib/archive_lib.php @@ -52,13 +55,13 @@ 'Category Weekly' => 'Par catégories et semaines', -## php/lib/block.mtsethashvar.php - ## php/lib/block.mtif.php ## php/lib/function.mtremotesigninlink.php - 'TypeKey authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'L\'authentification TypeKey n\'est pas activée sur ce blog. MTRemoteSignInLink ne peut être utilisé.', + 'TypePad authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'L\'authentification TypePad n\'est pas activée sur ce blog. MTRemoteSignInLink ne peut être utilisé.', ## php/lib/block.mtauthorhaspage.php 'No author available' => 'Il n\'a pas d\'auteurs disponibles', + +## php/lib/block.mtsethashvar.php ## php/lib/block.mtauthorhasentry.php @@ -67,12 +70,9 @@ '[_1] [_2]' => '[_1] [_2]', +## php/lib/function.mtcommentauthorlink.php + ## php/lib/captcha_lib.php 'Captcha' => 'Captcha', 'Type the characters you see in the picture above.' => 'Saisissez les caractÚres que vous voyez dans l\'image ci-dessus.', - -## php/lib/function.mtcommentauthorlink.php - -## php/lib/MTUtil.php - 'userpic-[_1]-%wx%h%x' => 'userpic-[_1]-%wx%h%x', ## php/lib/function.mtsetvar.php @@ -91,11 +91,11 @@ ## php/lib/function.mtauthordisplayname.php -## php/lib/function.mtcommentreplytolink.php - 'Reply' => 'Répondre', - ## php/lib/function.mtentryclasslabel.php 'page' => 'Page', 'entry' => 'note', 'Entry' => 'Note', + +## php/lib/function.mtcommentreplytolink.php + 'Reply' => 'Répondre', ## php/mt.php.pre Index: /trunk/php/lib/block.mtsethashvar.php =================================================================== --- /trunk/php/lib/block.mtsethashvar.php (revision 1651) +++ /trunk/php/lib/block.mtsethashvar.php (revision 3531) @@ -1,4 +1,4 @@ 'Fout: widgetset [_1] is leeg', + 'Error compiling widgetset [_1]' => 'Fout bij het compileren van widgetset [_1]', + +## php/lib/function.mtvar.php + 'You used a [_1] tag without a valid name attribute.' => 'U gebruikte een [_1] tag zonder geldig name attribuut', + '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' is geen geldige functie voor een hash.', + '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' is geen geldige functie voor een array.', + '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] is illegaal.', ## php/lib/function.mtassettype.php @@ -19,19 +29,12 @@ 'Video' => 'Video', -## php/lib/function.mtvar.php - 'You used a [_1] tag without a valid name attribute.' => 'U gebruikte een [_1] tag zonder geldig name attribuut', - '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' is geen geldige functie voor een hash.', - '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' is geen geldige functie voor een array.', - '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] is illegaal.', - -## php/lib/function.mtwidgetmanager.php - 'Error: widgetset [_1] is empty.' => 'Fout: widgetset [_1] is leeg', - 'Error compiling widgetset [_1]' => 'Fout bij het compileren van widgetset [_1]', - ## php/lib/thumbnail_lib.php - 'GD support has not been available. Please install GD support.' => 'GD ondersteuning niet beschikbaar. Gelieve GD ondersteuning te installeren.', # Translate - New + 'GD support has not been available. Please install GD support.' => 'GD ondersteuning niet beschikbaar. Gelieve GD ondersteuning te installeren.', ## php/lib/function.mtcommentauthor.php 'Anonymous' => 'Anonieme', + +## php/lib/MTUtil.php + 'userpic-[_1]-%wx%h%x' => 'gebruikersafbeelding-[_1]-%wx%h%x', ## php/lib/archive_lib.php @@ -53,13 +56,13 @@ 'Category Weekly' => 'per categorie per week', -## php/lib/block.mtsethashvar.php - ## php/lib/block.mtif.php ## php/lib/function.mtremotesigninlink.php - 'TypeKey authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'TypeKey authenticatie is niet ingeschakeld op deze blog. MTRemoteSignInLink kan niet worden gebruikt.', + 'TypePad authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'TypePad authenticatie is niet ingeschakeld op deze blog. MTRemoteSignInLink kan niet gebruikt worden.', ## php/lib/block.mtauthorhaspage.php 'No author available' => 'Geen auteur beschikbaar', + +## php/lib/block.mtsethashvar.php ## php/lib/block.mtauthorhasentry.php @@ -68,12 +71,9 @@ '[_1] [_2]' => '[_1] [_2]', +## php/lib/function.mtcommentauthorlink.php + ## php/lib/captcha_lib.php 'Captcha' => 'Captcha', 'Type the characters you see in the picture above.' => 'Tik te tekens in die u ziet in de afbeelding hierboven.', - -## php/lib/function.mtcommentauthorlink.php - -## php/lib/MTUtil.php - 'userpic-[_1]-%wx%h%x' => 'gebruikersafbeelding-[_1]-%wx%h%x', ## php/lib/function.mtsetvar.php @@ -92,7 +92,4 @@ ## php/lib/function.mtauthordisplayname.php -## php/lib/function.mtcommentreplytolink.php - 'Reply' => 'Antwoorden', - ## php/lib/function.mtentryclasslabel.php 'page' => 'pagina', @@ -100,7 +97,9 @@ 'Entry' => 'Bericht', +## php/lib/function.mtcommentreplytolink.php + 'Reply' => 'Antwoorden', + ## php/mt.php.pre 'Page not found - [_1]' => 'Pagina niet gevonden - [_1]', -); function translate_phrase($str, $params = null) { global $Lexicon, $Lexicon_nl; Index: /trunk/php/lib/function.mtcommentrepliesrecurse.php =================================================================== --- /trunk/php/lib/function.mtcommentrepliesrecurse.php (revision 2294) +++ /trunk/php/lib/function.mtcommentrepliesrecurse.php (revision 3531) @@ -1,4 +1,4 @@ error($ctx->mt->translate("TypeKey authentication is not enabled in this blog. MTRemoteSignInLink can't be used.")); + return $ctx->error($ctx->mt->translate("TypePad authentication is not enabled in this blog. MTRemoteSignInLink can't be used.")); } $blog_id = $blog['blog_id']; Index: /trunk/php/lib/block.mtifcommentsallowed.php =================================================================== --- /trunk/php/lib/block.mtifcommentsallowed.php (revision 1174) +++ /trunk/php/lib/block.mtifcommentsallowed.php (revision 3531) @@ -1,4 +1,4 @@ 'Fehler: Die Widgetgruppe \'[_1]\' ist leer.', + 'Error compiling widgetset [_1]' => 'Fehler bei Kompilierung der Widgetgruppe \'[_1]\'', + +## php/lib/function.mtvar.php + 'You used a [_1] tag without a valid name attribute.' => '\'[_1]\'-Befehl ohne gÌltiges Namensattribut verwendet.', + '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' ist keine gÌltige Hash-Funktion.', + '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' ist keine gÌltige Array-Funktion.', + '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] ist ungÌltig.', + ## php/lib/function.mtassettype.php 'image' => 'Bild', @@ -18,19 +28,12 @@ 'Video' => 'Video', -## php/lib/function.mtvar.php - 'You used a [_1] tag without a valid name attribute.' => '\'[_1]\'-Befehl ohne gÌltiges Namensattribut verwendet.', - '\'[_1]\' is not a valid function for a hash.' => '\'[_1]\' ist keine gÌltige Hash-Funktion.', - '\'[_1]\' is not a valid function for an array.' => '\'[_1]\' ist keine gÌltige Array-Funktion.', - '[_1] [_2] [_3] is illegal.' => '[_1] [_2] [_3] ist ungÌltig.', - -## php/lib/function.mtwidgetmanager.php - 'Error: widgetset [_1] is empty.' => 'Fehler: Die Widgetgruppe \'[_1]\' ist leer.', - 'Error compiling widgetset [_1]' => 'Fehler bei Kompilierung der Widgetgruppe \'[_1]\'', - ## php/lib/thumbnail_lib.php - 'GD support has not been available. Please install GD support.' => 'Keine GD-UnterstÌtzung vorhanden. Bitte installieren Sie die GD-Bibliothek.', # Translate - New # OK + 'GD support has not been available. Please install GD support.' => 'Keine GD-UnterstÌtzung vorhanden. Bitte installieren Sie die GD-Bibliothek.', ## php/lib/function.mtcommentauthor.php 'Anonymous' => 'Anonym', + +## php/lib/MTUtil.php + 'userpic-[_1]-%wx%h%x' => 'userpic-[_1]-%wx%h%x', ## php/lib/archive_lib.php @@ -52,13 +55,13 @@ 'Category Weekly' => 'Kategorie wöchentlich', -## php/lib/block.mtsethashvar.php - ## php/lib/block.mtif.php ## php/lib/function.mtremotesigninlink.php - 'TypeKey authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'TypeKey-Authentifizierung ist in diesem Blog nicht aktiviert. MTRemoteSignInLink kann daher nicht verwendet werden.', + 'TypePad authentication is not enabled in this blog. MTRemoteSignInLink can\'t be used.' => 'TypePad-Authentifizierung ist fÌr dieses Blog nicht aktiviert. MTremoteSignInLink kann daher nicht verwendet werden.', ## php/lib/block.mtauthorhaspage.php 'No author available' => 'Kein Autor verfÌgbar', + +## php/lib/block.mtsethashvar.php ## php/lib/block.mtauthorhasentry.php @@ -67,15 +70,12 @@ '[_1] [_2]' => '[_1] [_2]', +## php/lib/function.mtcommentauthorlink.php + ## php/lib/captcha_lib.php 'Captcha' => 'Captcha', - 'Type the characters you see in the picture above.' => 'Geben Sie die Buchstaben ein, die Sie in obigem Bild sehen.', - -## php/lib/function.mtcommentauthorlink.php - -## php/lib/MTUtil.php - 'userpic-[_1]-%wx%h%x' => 'userpic-[_1]-%wx%h%x', + 'Type the characters you see in the picture above.' => 'Geben Sie die Zeichen ein, die Sie im obigen Bild sehen.', ## php/lib/function.mtsetvar.php - '\'[_1]\' is not a hash.' => '\'[_1]\' ist kein Hash-Wert.', + '\'[_1]\' is not a hash.' => '\'[_1]\' ist kein Hash.', 'Invalid index.' => 'Index ungÌltig.', '\'[_1]\' is not an array.' => '\'[_1]\' ist kein Array.', @@ -91,11 +91,11 @@ ## php/lib/function.mtauthordisplayname.php -## php/lib/function.mtcommentreplytolink.php - 'Reply' => 'Antworten', - ## php/lib/function.mtentryclasslabel.php 'page' => 'Seite', 'entry' => 'Eintrag', 'Entry' => 'Eintrag', + +## php/lib/function.mtcommentreplytolink.php + 'Reply' => 'Antworten', ## php/mt.php.pre Index: /trunk/php/lib/function.mtauthoruserpic.php =================================================================== --- /trunk/php/lib/function.mtauthoruserpic.php (revision 2651) +++ /trunk/php/lib/function.mtauthoruserpic.php (revision 3531) @@ -1,4 +1,4 @@ stash('asset'); $blog_id = $asset['asset_blog_id']; - $tags = $ctx->mt->db->fetch_asset_tags(array('blog_id' => $blog_id)); - if (!is_array($tags)) $tags = array(); - - $min = 0; $max = 0; - $all_count = 0; - $tagnames = ''; - foreach ($tags as $tag) { - $count = $tag['tag_count']; - if ($count > $max) $max = $count; - if ($count < $min or $min == 0) $min = $count; - $all_count += $count; - } - $ctx->stash('tag_min_count', $min); - $ctx->stash('tag_max_count', $max); - $ctx->stash('all_tag_count', $all_count); $tags = $ctx->mt->db->fetch_asset_tags(array('asset_id' => $asset['asset_id'], 'blog_id' => $blog_id)); Index: /trunk/php/lib/block.mtentryadditionalcategories.php =================================================================== --- /trunk/php/lib/block.mtentryadditionalcategories.php (revision 1926) +++ /trunk/php/lib/block.mtentryadditionalcategories.php (revision 3531) @@ -1,4 +1,4 @@ stash('entry'); $blog_id = $entry['entry_blog_id']; - $tags = $ctx->mt->db->fetch_entry_tags(array('blog_id' => $blog_id, 'class' => $class)); - if (!is_array($tags)) $tags = array(); - - $min = 0; $max = 0; - $all_count = 0; - $tagnames = ''; - foreach ($tags as $tag) { - $count = $tag['tag_count']; - if ($count > $max) $max = $count; - if ($count < $min or $min == 0) $min = $count; - $all_count += $count; - } - $ctx->stash('tag_min_count', $min); - $ctx->stash('tag_max_count', $max); - $ctx->stash('all_tag_count', $all_count); $entry = $ctx->stash('entry'); Index: /trunk/php/lib/block.mtentriesheader.php =================================================================== --- /trunk/php/lib/block.mtentriesheader.php (revision 1174) +++ /trunk/php/lib/block.mtentriesheader.php (revision 3531) @@ -1,4 +1,4 @@ 1, 'mtsetvartemplate' => 1, + 'mtincludeblock' => 1, ); Index: /trunk/php/lib/function.mtusersessioncookiename.php =================================================================== --- /trunk/php/lib/function.mtusersessioncookiename.php (revision 2239) +++ /trunk/php/lib/function.mtusersessioncookiename.php (revision 3531) @@ -1,4 +1,4 @@ stash('blog'); - $moderated = ($blog['blog_moderate_pings']; + $moderated = ($blog['blog_moderate_pings']); return $ctx->_hdlr_if($args, $content, $ctx, $repeat, $moderated); } else { Index: /trunk/php/lib/function.mtcommentfields.php =================================================================== --- /trunk/php/lib/function.mtcommentfields.php (revision 1174) +++ /trunk/php/lib/function.mtcommentfields.php (revision 3531) @@ -1,4 +1,4 @@ stash('blog_id'); + if ($args['local']) + $blog_id = $ctx->stash('local_blog_id'); $blog = $ctx->mt->db->fetch_blog($blog_id); Index: /trunk/php/lib/modifier.encode_xml.php =================================================================== --- /trunk/php/lib/modifier.encode_xml.php (revision 1174) +++ /trunk/php/lib/modifier.encode_xml.php (revision 3531) @@ -1,4 +1,4 @@ fetch_categories(array_merge($blog_ctx_arg, array('show_empty' => 1, 'class' => $cat_class))); + $cats =& $this->fetch_categories(array_merge($blog_ctx_arg, array('show_empty' => 1, 'class' => $cat_class, 'label' => $labels))); else - $cats =& $this->fetch_categories(array('blog_id' => $blog_id, 'show_empty' => 1, 'class' => $cat_class)); + $cats =& $this->fetch_categories(array('blog_id' => $blog_id, 'show_empty' => 1, 'class' => $cat_class, 'label' => $labels)); } if (!is_array($cats)) $cats = array(); @@ -1328,5 +1329,15 @@ } } elseif (isset($args['label'])) { - $cat_filter = 'and category_label = \''.$this->escape($args['label']).'\''; + if (is_array($args['label'])) { + $labels = ''; + foreach ($args['label'] as $c) { + if ($labels != '') + $labels .= ','; + $labels .= "'".$this->escape($c)."'"; + } + $cat_filter = 'and category_label in ('.$labels.')'; + } else { + $cat_filter = 'and category_label = \''.$this->escape($args['label']).'\''; + } } else { $limit = $args['lastn']; @@ -1570,15 +1581,46 @@ $re_sort = false; if (isset($args['namespace'])) { - require_once("MTUtil.php"); - $arg_names = array('min_score', 'max_score', 'min_rate', 'max_rate', 'min_count', 'max_count' ); - foreach ($arg_names as $n) { - if (isset($args[$n])) { - $rating_args = $args[$n]; - $cexpr = create_rating_expr_function($rating_args, $n, $args['namespace'], 'author'); - if ($cexpr) { - $filters[] = $cexpr; - $re_sort = true; - } else { - return null; + if (isset($args['scoring_to'])) { + require_once("MTUtil.php"); + require_once("rating_lib.php"); + $type = $args['scoring_to']; + $obj = $args['_scoring_to_obj']; + $obj_id = $obj[$type.'_id']; + if (isset($args['min_score'])) { + $expr = '$ctx = $c;if ($ctx == null) { global $mt; $ctx = $mt->context(); } $old = $ctx->mt->db->result; '; + $expr .= '$sc = get_score($ctx, '.$obj_id.', "'.$type.'", "'.$args['namespace'].'", $e["author_id"]);'; + $expr .= '$ret = $sc >= '.$args['min_score'].';'; + $expr .= ' $ctx->mt->db->result = $old; return $ret;'; + $fn = create_function('&$e,&$c', $expr); + $filters[] = $fn; + } elseif (isset($args['max_score'])) { + $expr = '$ctx = $c;if ($ctx == null) { global $mt; $ctx = $mt->context(); } $old = $ctx->mt->db->result; '; + $expr .= '$sc = get_score($ctx, '.$obj_id.', "'.$type.'", "'.$args['namespace'].'", $e["author_id"]);'; + $expr .= '$ret = $sc <= '.$args['max_score'].';'; + $expr .= ' $ctx->mt->db->result = $old; return $ret;'; + $fn = create_function('&$e,&$c', $expr); + $filters[] = $fn; + } + else { + $expr = '$ctx = $c;if ($ctx == null) { global $mt; $ctx = $mt->context(); } $old = $ctx->mt->db->result; '; + $expr .= '$ret = !is_null($ctx->mt->db->fetch_score('.$args['namespace'].','.$obj_id.', $e["author_id"],'.$type.'));'; + $expr .= ' $ctx->mt->db->result = $old; return $ret;'; + $fn = create_function('&$e,&$c', $expr); + $filters[] = $fn; + } + } + else { + require_once("MTUtil.php"); + $arg_names = array('min_score', 'max_score', 'min_rate', 'max_rate', 'min_count', 'max_count' ); + foreach ($arg_names as $n) { + if (isset($args[$n])) { + $rating_args = $args[$n]; + $cexpr = create_rating_expr_function($rating_args, $n, $args['namespace'], 'author'); + if ($cexpr) { + $filters[] = $cexpr; + $re_sort = true; + } else { + return null; + } } } Index: /trunk/php/lib/block.mtifcommenterisauthor.php =================================================================== --- /trunk/php/lib/block.mtifcommenterisauthor.php (revision 1174) +++ /trunk/php/lib/block.mtifcommenterisauthor.php (revision 3531) @@ -1,4 +1,4 @@ Index: /trunk/php/lib/block.mtsubcatislast.php =================================================================== --- /trunk/php/lib/block.mtsubcatislast.php (revision 1174) +++ /trunk/php/lib/block.mtsubcatislast.php (revision 3531) @@ -1,4 +1,4 @@ get_thumbnail($dest, $thumb_w, $thumb_h, $asset['asset_id'], $scale, $thumb_name, 'png')) { + if (!$thumb->get_thumbnail($dest, $thumb_w, $thumb_h, $asset['asset_id'], $scale, $thumb_name, 'png', true)) { return ''; } @@ -1313,17 +1313,22 @@ } -# for compatibility... -function make_thumbnail_file($src, $dest, $width, $height, $scale = 0, $dest_type = 'auto', $id = 0) { - require_once('thumbnail_lib.php'); - $thumb = new Thumbnail($src); - - $thumb_w = $width; - $thumb_h = $height; - $thumb->get_thumbnail($dest, $thumb_w, $thumb_h, $id, $scale, null, $dest_type); - - return array($thumb_w, $thumb_h); -} - -function get_thumbnail_file($asset, $blog, $width = 0, $height = 0, $scale = 0, $format = '%f-thumb-%wx%h-%i%x') { +function get_thumbnail_file($asset, $blog, $args) { + # Parse args + $width = 0; + $height = 0; + $scale = 0; + $square = false; + $format = '%f-thumb-%wx%h-%i%x'; + if (isset($args['width'])) + $width = $args['width']; + if (isset($args['height'])) + $height = $args['height']; + if (isset($args['scale'])) + $scale = $args['scale']; + if (isset($args['format'])) + $format = $args['format']; + if (isset($args['square'])) + $square = ((int)$args['square'] == 1) ? true : false; + # Get parameter $site_path = $blog['blog_site_path']; @@ -1353,5 +1358,5 @@ $thumb_h = $height; $dest; - if (!$thumb->get_thumbnail($dest, $thumb_w, $thumb_h, $asset['asset_id'], $scale, $thumb_name)) { + if (!$thumb->get_thumbnail($dest, $thumb_w, $thumb_h, $asset['asset_id'], $scale, $thumb_name, 'auto', $square )) { return ''; } @@ -1573,3 +1578,15 @@ } +# for compatibility... +function make_thumbnail_file($src, $dest, $width, $height, $scale = 0, $dest_type = 'auto', $id = 0, $scale = false) { + require_once('thumbnail_lib.php'); + $thumb = new Thumbnail($src); + + $thumb_w = $width; + $thumb_h = $height; + $thumb->get_thumbnail($dest, $thumb_w, $thumb_h, $id, $scale, null, $dest_type, $scale); + + return array($thumb_w, $thumb_h); +} + ?> Index: /trunk/php/lib/function.mtpageid.php =================================================================== --- /trunk/php/lib/function.mtpageid.php (revision 1174) +++ /trunk/php/lib/function.mtpageid.php (revision 3531) @@ -1,4 +1,4 @@ = current_date()'; + $days . ' day) >= current_timestamp'; } Index: /trunk/php/lib/block.mtifisdescendant.php =================================================================== --- /trunk/php/lib/block.mtifisdescendant.php (revision 1174) +++ /trunk/php/lib/block.mtifisdescendant.php (revision 3531) @@ -1,4 +1,4 @@ = current_date)'; + return '(' . $column . '+\'' . $days . ' days\' >= current_timestamp)'; } Index: /trunk/php/lib/function.mtpingexcerpt.php =================================================================== --- /trunk/php/lib/function.mtpingexcerpt.php (revision 1174) +++ /trunk/php/lib/function.mtpingexcerpt.php (revision 3531) @@ -1,4 +1,4 @@ stash('blog_id', $blog_id); + $ctx->stash('local_blog_id', $blog_id); $ctx->stash('blog', $blog); $ctx->stash('build_template_id', $tpl_id); @@ -679,4 +680,5 @@ $ctx->stash('blog', $blog); $ctx->stash('blog_id', $this->blog_id); + $ctx->stash('local_blog_id', $this->blog_id); $this->configure_paths($blog['blog_site_path']); } @@ -694,4 +696,5 @@ $ctx->stash('blog', $blog); $ctx->stash('blog_id', $this->blog_id); + $ctx->stash('local_blog_id', $this->blog_id); $this->configure_paths($blog['blog_site_path']); } @@ -731,4 +734,5 @@ $ctx =& $this->context(); $ctx->stash('blog_id', $this->blog_id); + $ctx->stash('local_blog_id', $this->blog_id); $ctx->stash('blog', $this->db->fetch_blog($this->blog_id)); $ctx->stash('error_message', $errstr.""); Index: /trunk/extlib/Apache/XMLRPC/Lite.pm =================================================================== --- /trunk/extlib/Apache/XMLRPC/Lite.pm (revision 1098) +++ /trunk/extlib/Apache/XMLRPC/Lite.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: Lite.pm,v 1.3 2001/08/11 19:09:57 paulk Exp $ +# $Id: Lite.pm 249 2008-05-05 20:35:05Z kutterma $ # # ====================================================================== @@ -16,7 +16,12 @@ @ISA = qw(XMLRPC::Transport::HTTP::Apache); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); +use version; $VERSION = qv('0.710.05'); my $server = __PACKAGE__->new; + +sub server { + return $server; +} sub handler { @@ -68,11 +73,11 @@ =head1 DESCRIPTION -This Apache Perl module provides the ability to add support for XML-RPC -protocol with easy configuration (either in .conf or in .htaccess file). +This Apache Perl module provides the ability to add support for XML-RPC +protocol with easy configuration (either in .conf or in .htaccess file). This functionality should give you lightweight option for hosting SOAP services and greatly simplify configuration aspects. This module inherites functionality from XMLRPC::Transport::HTTP::Apache component of XMLRPC::Lite module. - + =head1 CONFIGURATION @@ -80,6 +85,6 @@ directives in main server configuration areas or directly in .htaccess file. -All parameters should be quoted and can be separated with commas or spaces -for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters +All parameters should be quoted and can be separated with commas or spaces +for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters ("key1 => value1, key2 => value2"). @@ -92,5 +97,5 @@ =item dispatch_to (LIST) -Specifies path to directory that contains Perl modules you'd like to give +Specifies path to directory that contains Perl modules you'd like to give access to, or just list of modules (for preloaded modules). @@ -99,6 +104,6 @@ =item options (HASH) -Specifies list of options for your module, for example threshold for -compression. Future versions will support more options. See +Specifies list of options for your module, for example threshold for +compression. Future versions will support more options. See XMLRPC::Transport::HTTP documentation for other options. @@ -106,4 +111,18 @@ =back + +=head1 METHODS/SUBROUTINES + +=head2 server + + my $server = Apache::XMLRPC::Lite->server(); + +Returns the server object. + +Useful if you need to manipulate the server object from your code. + +=head2 handle + +Request handler. Called by apache. =head1 DEPENDENCIES Index: /trunk/extlib/Apache/SOAP.pm =================================================================== --- /trunk/extlib/Apache/SOAP.pm (revision 1098) +++ /trunk/extlib/Apache/SOAP.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: SOAP.pm,v 1.3 2001/08/11 19:09:57 paulk Exp $ +# $Id: SOAP.pm 249 2008-05-05 20:35:05Z kutterma $ # # ====================================================================== @@ -16,7 +16,11 @@ @ISA = qw(SOAP::Transport::HTTP::Apache); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +use version; $VERSION = qv('0.710.05'); my $server = __PACKAGE__->new; + +sub server { + return $server; +} sub handler { @@ -68,11 +72,11 @@ =head1 DESCRIPTION -This Apache Perl module provides the ability to add support for SOAP (Simple -Object Access Protocol) protocol with easy configuration (either in .conf or +This Apache Perl module provides the ability to add support for SOAP (Simple +Object Access Protocol) protocol with easy configuration (either in .conf or in .htaccess file). This functionality should give you lightweight option for hosting SOAP services and greatly simplify configuration aspects. This module inherites functionality from SOAP::Transport::HTTP::Apache component of SOAP::Lite module. - + =head1 CONFIGURATION @@ -80,6 +84,6 @@ directives in main server configuration areas or directly in .htaccess file. -All parameters should be quoted and can be separated with commas or spaces -for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters +All parameters should be quoted and can be separated with commas or spaces +for lists ("a, b, c") and with 'wide arrows' and commas for hash parameters ("key1 => value1, key2 => value2"). @@ -92,5 +96,5 @@ =item dispatch_to (LIST) -Specifies path to directory that contains Perl modules you'd like to give +Specifies path to directory that contains Perl modules you'd like to give access to, or just list of modules (for preloaded modules). @@ -99,6 +103,6 @@ =item options (HASH) -Specifies list of options for your module, for example threshold for -compression. Future versions will support more options. See +Specifies list of options for your module, for example threshold for +compression. Future versions will support more options. See SOAP::Transport::HTTP documentation for other options. @@ -106,4 +110,18 @@ =back + +=head1 METHODS/SUBROUTINES + +=head2 server + + my $server = Apache::XMLRPC::Lite->server(); + +Returns the server object. + +Useful if you need to manipulate the server object from your code. + +=head2 handle + +Request handler. Called by apache. =head1 DEPENDENCIES Index: /trunk/extlib/UDDI/Lite.pm =================================================================== --- /trunk/extlib/UDDI/Lite.pm (revision 1098) +++ /trunk/extlib/UDDI/Lite.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: Lite.pm 22194 2006-01-25 22:20:57Z bchoate $ +# $Id: Lite.pm 131 2007-11-16 10:43:28Z kutterma $ # # ====================================================================== @@ -14,7 +14,697 @@ use strict; use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); + +#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); +$VERSION = $SOAP::Lite::VERSION; use SOAP::Lite; + +# ====================================================================== + +package UDDI::Constants; + +BEGIN +{ + use vars + qw(%UDDI_VERSIONS $ELEMENTS $ATTRIBUTES $WITHNAMES $NAMESPACE $GENERIC); + + %UDDI_VERSIONS = ( + 1 => { + ELEMENTS => { + address => { addressLine => 1 }, + authToken => { authInfo => 1 }, + bindingDetail => { bindingTemplate => 1 }, + bindingTemplate => { + accessPoint => 1, + description => 1, + hostingRedirector => 1, + tModelInstanceDetails => 1 + }, + bindingTemplates => { bindingTemplate => 1 }, + businessDetail => { businessEntity => 1 }, + businessDetailExt => { businessEntityExt => 1 }, + businessEntity => { + businessServices => 1, + categoryBag => 1, + contacts => 1, + description => 1, + discoveryURLs => 1, + identifierBag => 1, + name => 1 + }, + businessEntityExt => { businessEntity => 1 }, + businessInfo => + { description => 1, name => 1, serviceInfos => 1 }, + businessInfos => { businessInfo => 1 }, + businessList => { businessInfos => 1 }, + businessService => { + bindingTemplates => 1, + categoryBag => 1, + description => 1, + name => 1 + }, + businessServices => { businessService => 1 }, + categoryBag => { keyedReference => 1 }, + contact => { + address => 1, + description => 1, + email => 1, + personName => 1, + phone => 1 + }, + contacts => { contact => 1 }, + delete_binding => { authInfo => 1, bindingKey => 1 }, + delete_business => { authInfo => 1, businessKey => 1 }, + delete_service => { authInfo => 1, serviceKey => 1 }, + delete_tModel => { authInfo => 1, tModelKey => 1 }, + discard_authToken => { authInfo => 1 }, + discoveryURLs => { discoveryUrl => 1 }, + dispositionReport => { result => 1 }, + findQualifiers => { findQualifier => 1 }, + find_binding => { findQualifiers => 1, tModelBag => 1 }, + find_business => { + categoryBag => 1, + discoveryURLs => 1, + findQualifiers => 1, + identifierBag => 1, + name => 1, + tModelBag => 1 + }, + find_service => { + categoryBag => 1, + findQualifiers => 1, + name => 1, + tModelBag => 1 + }, + find_tModel => { + categoryBag => 1, + findQualifiers => 1, + identifierBag => 1, + name => 1 + }, + get_bindingDetail => { bindingKey => 1 }, + get_businessDetail => { businessKey => 1 }, + get_businessDetailExt => { businessKey => 1 }, + get_registeredInfo => { authInfo => 1 }, + get_serviceDetail => { serviceKey => 1 }, + get_tModelDetail => { tModelKey => 1 }, + identifierBag => { keyedReference => 1 }, + instanceDetails => + { description => 1, instanceParms => 1, overviewDoc => 1 }, + overviewDoc => { description => 1, overviewURL => 1 }, + registeredInfo => { businessInfos => 1, tModelInfos => 1 }, + result => { errInfo => 1 }, + save_binding => { authInfo => 1, bindingTemplate => 1 }, + save_business => + { authInfo => 1, businessEntity => 1, uploadRegister => 1 }, + save_service => { authInfo => 1, businessService => 1 }, + save_tModel => + { authInfo => 1, tModel => 1, uploadRegister => 1 }, + serviceDetail => { businessService => 1 }, + serviceInfo => { name => 1 }, + serviceInfos => { serviceInfo => 1 }, + serviceList => { serviceInfos => 1 }, + tModel => { + categoryBag => 1, + description => 1, + identifierBag => 1, + name => 1, + overviewDoc => 1 + }, + tModelBag => { tModelKey => 1 }, + tModelDetail => { tModel => 1 }, + tModelInfo => { name => 1 }, + tModelInfos => { tModelInfo => 1 }, + tModelInstanceDetails => { tModelInstanceInfo => 1 }, + tModelInstanceInfo => + { description => 1, instanceDetails => 1 }, + tModelList => { tModelInfos => 1 }, + validate_categorization => { + businessEntity => 1, + businessService => 1, + keyValue => 1, + tModel => 1, + tModelKey => 1 + } + }, + ATTRIBUTES => { + accessPoint => { URLType => 2 }, + address => { sortCode => 2, useType => 2 }, + authToken => { generic => 2, operator => 2 }, + bindingDetail => + { generic => 2, operator => 2, truncated => 2 }, + bindingTemplate => { bindingKey => 2, serviceKey => 2 }, + businessDetail => + { generic => 2, operator => 2, truncated => 2 }, + businessDetailExt => + { generic => 2, operator => 2, truncated => 2 }, + businessEntity => + { authorizedName => 2, businessKey => 2, operator => 2 }, + businessInfo => { businessKey => 2 }, + businessList => + { generic => 2, operator => 2, truncated => 2 }, + businessService => { businessKey => 2, serviceKey => 2 }, + contact => { useType => 2 }, + delete_binding => { generic => 2 }, + delete_business => { generic => 2 }, + delete_service => { generic => 2 }, + delete_tModel => { generic => 2 }, + description => { lang => 2 }, + discard_authToken => { generic => 2 }, + discoveryUrl => { useType => 2 }, + dispositionReport => + { generic => 2, operator => 2, truncated => 2 }, + email => { useType => 2 }, + errInfo => { errCode => 2 }, + find_binding => + { generic => 2, maxRows => 2, serviceKey => 2 }, + find_business => { generic => 2, maxRows => 2 }, + find_service => + { businessKey => 2, generic => 2, maxRows => 2 }, + find_tModel => { generic => 2, maxRows => 2 }, + get_authToken => { cred => 2, generic => 2, userID => 2 }, + get_bindingDetail => { generic => 2 }, + get_businessDetail => { generic => 2 }, + get_businessDetailExt => { generic => 2 }, + get_registeredInfo => { generic => 2 }, + get_serviceDetail => { generic => 2 }, + get_tModelDetail => { generic => 2 }, + hostingRedirector => { bindingKey => 2 }, + keyedReference => + { keyName => 2, keyValue => 2, tModelKey => 2 }, + phone => { useType => 2 }, + registeredInfo => + { generic => 2, operator => 2, truncated => 2 }, + result => { errno => 2, keyType => 2 }, + save_binding => { generic => 2 }, + save_business => { generic => 2 }, + save_service => { generic => 2 }, + save_tModel => { generic => 2 }, + serviceDetail => + { generic => 2, operator => 2, truncated => 2 }, + serviceInfo => { businessKey => 2, serviceKey => 2 }, + serviceList => + { generic => 2, operator => 2, truncated => 2 }, + tModel => + { authorizedName => 2, operator => 2, tModelKey => 2 }, + tModelDetail => + { generic => 2, operator => 2, truncated => 2 }, + tModelInfo => { tModelKey => 2 }, + tModelInstanceInfo => { tModelKey => 2 }, + tModelList => { generic => 2, operator => 2, truncated => 2 }, + validate_categorization => { generic => 2 } + }, + WITHNAMES => [ + qw/accessPoint address addressLine authInfo authToken bindingDetail bindingKey bindingTemplate bindingTemplates businessDetail businessDetailExt businessEntity businessEntityExt businessInfo businessInfos businessKey businessList businessService businessServices categoryBag contact contacts description discoveryURLs discoveryUrl dispositionReport email errInfo findQualifier findQualifiers hostingRedirector identifierBag instanceDetails instanceParms keyValue keyedReference name overviewDoc overviewURL personName phone registeredInfo result serviceDetail serviceInfo serviceInfos serviceKey serviceList tModel tModelBag tModelDetail tModelInfo tModelInfos tModelInstanceDetails tModelInstanceInfo tModelKey tModelList uploadRegister/ + ], + NAMESPACE => 'urn:uddi-org:api', + GENERIC => '1.0', # string, not number; '.0' matters + }, + 2 => { + ELEMENTS => { + add_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + address => { addressLine => 1 }, + assertionStatusItem => { + fromKey => 1, + keyedReference => 1, + keysOwned => 1, + toKey => 1 + }, + assertionStatusReport => { assertionStatusItem => 1 }, + authToken => { authInfo => 1 }, + bindingDetail => { bindingTemplate => 1 }, + bindingTemplate => { + accessPoint => 1, + description => 1, + hostingRedirector => 1, + tModelInstanceDetails => 1 + }, + bindingTemplates => { bindingTemplate => 1 }, + businessDetail => { businessEntity => 1 }, + businessDetailExt => { businessEntityExt => 1 }, + businessEntity => { + businessServices => 1, + categoryBag => 1, + contacts => 1, + description => 1, + discoveryURLs => 1, + identifierBag => 1, + name => 1 + }, + businessEntityExt => { businessEntity => 1 }, + businessInfo => + { description => 1, name => 1, serviceInfos => 1 }, + businessInfos => { businessInfo => 1 }, + businessList => { businessInfos => 1 }, + businessService => { + bindingTemplates => 1, + categoryBag => 1, + description => 1, + name => 1 + }, + businessServices => { businessService => 1 }, + categoryBag => { keyedReference => 1 }, + contact => { + address => 1, + description => 1, + email => 1, + personName => 1, + phone => 1 + }, + contacts => { contact => 1 }, + delete_binding => { authInfo => 1, bindingKey => 1 }, + delete_business => { authInfo => 1, businessKey => 1 }, + delete_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + delete_service => { authInfo => 1, serviceKey => 1 }, + delete_tModel => { authInfo => 1, tModelKey => 1 }, + discard_authToken => { authInfo => 1 }, + discoveryURLs => { discoveryURL => 1 }, + dispositionReport => { result => 1 }, + findQualifiers => { findQualifier => 1 }, + find_binding => { findQualifiers => 1, tModelBag => 1 }, + find_business => { + categoryBag => 1, + discoveryURLs => 1, + findQualifiers => 1, + identifierBag => 1, + name => 1, + tModelBag => 1 + }, + find_relatedBusinesses => { + businessKey => 1, + findQualifiers => 1, + keyedReference => 1 + }, + find_service => { + categoryBag => 1, + findQualifiers => 1, + name => 1, + tModelBag => 1 + }, + find_tModel => { + categoryBag => 1, + findQualifiers => 1, + identifierBag => 1, + name => 1 + }, + get_assertionStatusReport => + { authInfo => 1, completionStatus => 1 }, + get_bindingDetail => { bindingKey => 1 }, + get_businessDetail => { businessKey => 1 }, + get_businessDetailExt => { businessKey => 1 }, + get_publisherAssertions => { authInfo => 1 }, + get_registeredInfo => { authInfo => 1 }, + get_serviceDetail => { serviceKey => 1 }, + get_tModelDetail => { tModelKey => 1 }, + identifierBag => { keyedReference => 1 }, + instanceDetails => + { description => 1, instanceParms => 1, overviewDoc => 1 }, + keysOwned => { fromKey => 1, toKey => 1 }, + overviewDoc => { description => 1, overviewURL => 1 }, + publisherAssertion => + { fromKey => 1, keyedReference => 1, toKey => 1 }, + publisherAssertions => { publisherAssertion => 1 }, + registeredInfo => { businessInfos => 1, tModelInfos => 1 }, + relatedBusinessInfo => { + businessKey => 1, + description => 1, + name => 1, + sharedRelationships => 1 + }, + relatedBusinessInfos => { relatedBusinessInfo => 1 }, + relatedBusinessesList => + { businessKey => 1, relatedBusinessInfos => 1 }, + result => { errInfo => 1 }, + save_binding => { authInfo => 1, bindingTemplate => 1 }, + save_business => + { authInfo => 1, businessEntity => 1, uploadRegister => 1 }, + save_service => { authInfo => 1, businessService => 1 }, + save_tModel => + { authInfo => 1, tModel => 1, uploadRegister => 1 }, + serviceDetail => { businessService => 1 }, + serviceInfo => { name => 1 }, + serviceInfos => { serviceInfo => 1 }, + serviceList => { serviceInfos => 1 }, + set_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + sharedRelationships => { keyedReference => 1 }, + tModel => { + categoryBag => 1, + description => 1, + identifierBag => 1, + name => 1, + overviewDoc => 1 + }, + tModelBag => { tModelKey => 1 }, + tModelDetail => { tModel => 1 }, + tModelInfo => { name => 1 }, + tModelInfos => { tModelInfo => 1 }, + tModelInstanceDetails => { tModelInstanceInfo => 1 }, + tModelInstanceInfo => + { description => 1, instanceDetails => 1 }, + tModelList => { tModelInfos => 1 }, + validate_values => + { businessEntity => 1, businessService => 1, tModel => 1 } + }, + ATTRIBUTES => { + accessPoint => { URLType => 2 }, + add_publisherAssertions => { generic => 2 }, + address => { sortCode => 2, tModelKey => 2, useType => 2 }, + addressLine => { keyName => 2, keyValue => 2 }, + assertionStatusItem => { completionStatus => 2 }, + assertionStatusReport => { generic => 2, operator => 2 }, + authToken => { generic => 2, operator => 2 }, + bindingDetail => + { generic => 2, operator => 2, truncated => 2 }, + bindingTemplate => { bindingKey => 2, serviceKey => 2 }, + businessDetail => + { generic => 2, operator => 2, truncated => 2 }, + businessDetailExt => + { generic => 2, operator => 2, truncated => 2 }, + businessEntity => + { authorizedName => 2, businessKey => 2, operator => 2 }, + businessInfo => { businessKey => 2 }, + businessList => + { generic => 2, operator => 2, truncated => 2 }, + businessService => { businessKey => 2, serviceKey => 2 }, + contact => { useType => 2 }, + delete_binding => { generic => 2 }, + delete_business => { generic => 2 }, + delete_publisherAssertions => { generic => 2 }, + delete_service => { generic => 2 }, + delete_tModel => { generic => 2 }, + description => { lang => 2 }, + discard_authToken => { generic => 2 }, + discoveryURL => { useType => 2 }, + dispositionReport => + { generic => 2, operator => 2, truncated => 2 }, + email => { useType => 2 }, + errInfo => { errCode => 2 }, + find_binding => + { generic => 2, maxRows => 2, serviceKey => 2 }, + find_business => { generic => 2, maxRows => 2 }, + find_relatedBusinesses => { generic => 2, maxRows => 2 }, + find_service => + { businessKey => 2, generic => 2, maxRows => 2 }, + find_tModel => { generic => 2, maxRows => 2 }, + get_assertionStatusReport => { generic => 2 }, + get_authToken => { cred => 2, generic => 2, userID => 2 }, + get_bindingDetail => { generic => 2 }, + get_businessDetail => { generic => 2 }, + get_businessDetailExt => { generic => 2 }, + get_publisherAssertions => { generic => 2 }, + get_registeredInfo => { generic => 2 }, + get_serviceDetail => { generic => 2 }, + get_tModelDetail => { generic => 2 }, + hostingRedirector => { bindingKey => 2 }, + keyedReference => + { keyName => 2, keyValue => 2, tModelKey => 2 }, + name => { lang => 2 }, + phone => { useType => 2 }, + publisherAssertions => + { authorizedName => 2, generic => 2, operator => 2 }, + registeredInfo => + { generic => 2, operator => 2, truncated => 2 }, + relatedBusinessesList => + { generic => 2, operator => 2, truncated => 2 }, + result => { errno => 2, keyType => 2 }, + save_binding => { generic => 2 }, + save_business => { generic => 2 }, + save_service => { generic => 2 }, + save_tModel => { generic => 2 }, + serviceDetail => + { generic => 2, operator => 2, truncated => 2 }, + serviceInfo => { businessKey => 2, serviceKey => 2 }, + serviceList => + { generic => 2, operator => 2, truncated => 2 }, + set_publisherAssertions => { generic => 2 }, + sharedRelationships => { direction => 2 }, + tModel => + { authorizedName => 2, operator => 2, tModelKey => 2 }, + tModelDetail => + { generic => 2, operator => 2, truncated => 2 }, + tModelInfo => { tModelKey => 2 }, + tModelInstanceInfo => { tModelKey => 2 }, + tModelList => { generic => 2, operator => 2, truncated => 2 }, + validate_values => { generic => 2 } + }, + WITHNAMES => [ + qw/accessPoint address addressLine assertionStatusItem assertionStatusReport authInfo authToken bindingDetail bindingKey bindingTemplate bindingTemplates businessDetail businessDetailExt businessEntity businessEntityExt businessInfo businessInfos businessKey businessList businessService businessServices categoryBag completionStatus contact contacts description discoveryURL discoveryURLs dispositionReport email errInfo findQualifier findQualifiers fromKey hostingRedirector identifierBag instanceDetails instanceParms keyedReference keysOwned name overviewDoc overviewURL personName phone publisherAssertion publisherAssertions registeredInfo relatedBusinessInfo relatedBusinessInfos relatedBusinessesList result serviceDetail serviceInfo serviceInfos serviceKey serviceList sharedRelationships tModel tModelBag tModelDetail tModelInfo tModelInfos tModelInstanceDetails tModelInstanceInfo tModelKey tModelList toKey uploadRegister/ + ], + NAMESPACE => 'urn:uddi-org:api_v2', + GENERIC => '2.0', + }, + 3 => { + ELEMENTS => { + add_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + address => { addressLine => 1 }, + assertionStatusItem => { + fromKey => 1, + keyedReference => 1, + keysOwned => 1, + toKey => 1 + }, + assertionStatusReport => { assertionStatusItem => 1 }, + authToken => { authInfo => 1 }, + bindingDetail => + { bindingTemplate => 1, listDescription => 1 }, + bindingTemplate => { + accessPoint => 1, + categoryBag => 1, + description => 1, + Signature => 1, + hostingRedirector => 1, + tModelInstanceDetails => 1 + }, + bindingTemplates => { bindingTemplate => 1 }, + businessDetail => { businessEntity => 1 }, + businessEntity => { + businessServices => 1, + categoryBag => 1, + contacts => 1, + description => 1, + discoveryURLs => 1, + Signature => 1, + identifierBag => 1, + name => 1 + }, + businessInfo => + { description => 1, name => 1, serviceInfos => 1 }, + businessInfos => { businessInfo => 1 }, + businessList => { businessInfos => 1, listDescription => 1 }, + businessService => { + bindingTemplates => 1, + categoryBag => 1, + description => 1, + Signature => 1, + name => 1 + }, + businessServices => { businessService => 1 }, + categoryBag => { + keyedReference => 1, + keyedReferenceGroup => 1, + keyedReferenceGroup => 1 + }, + contact => { + address => 1, + description => 1, + email => 1, + personName => 1, + phone => 1 + }, + contacts => { contact => 1 }, + delete_binding => { authInfo => 1, bindingKey => 1 }, + delete_business => { authInfo => 1, businessKey => 1 }, + delete_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + delete_service => { authInfo => 1, serviceKey => 1 }, + delete_tModel => { authInfo => 1, tModelKey => 1 }, + discard_authToken => { authInfo => 1 }, + discoveryURLs => { discoveryURL => 1 }, + dispositionReport => { result => 1 }, + findQualifiers => { findQualifier => 1 }, + find_binding => { + authInfo => 1, + categoryBag => 1, + findQualifiers => 1, + find_tModel => 1, + tModelBag => 1 + }, + find_business => { + authInfo => 1, + categoryBag => 1, + discoveryURLs => 1, + findQualifiers => 1, + find_relatedBusinesses => 1, + find_tModel => 1, + identifierBag => 1, + name => 1, + tModelBag => 1 + }, + find_relatedBusinesses => { + authInfo => 1, + businessKey => 1, + findQualifiers => 1, + fromKey => 1, + keyedReference => 1, + toKey => 1 + }, + find_service => { + authInfo => 1, + categoryBag => 1, + findQualifiers => 1, + find_tModel => 1, + name => 1, + tModelBag => 1 + }, + find_tModel => { + authInfo => 1, + categoryBag => 1, + findQualifiers => 1, + identifierBag => 1, + name => 1 + }, + get_assertionStatusReport => + { authInfo => 1, completionStatus => 1 }, + get_bindingDetail => { authInfo => 1, bindingKey => 1 }, + get_businessDetail => { authInfo => 1, businessKey => 1 }, + get_operationalInfo => { authInfo => 1, entityKey => 1 }, + get_publisherAssertions => { authInfo => 1 }, + get_registeredInfo => { authInfo => 1 }, + get_serviceDetail => { authInfo => 1, serviceKey => 1 }, + get_tModelDetail => { authInfo => 1, tModelKey => 1 }, + identifierBag => { keyedReference => 1 }, + instanceDetails => { + description => 1, + instanceParms => 1, + instanceParms => 1, + overviewDoc => 1 + }, + keyedReferenceGroup => { keyedReference => 1 }, + keysOwned => { fromKey => 1, toKey => 1, toKey => 1 }, + listDescription => + { actualCount => 1, includeCount => 1, listHead => 1 }, + operationalInfo => { + authorizedName => 1, + created => 1, + modified => 1, + modifiedIncludingChildren => 1, + nodeID => 1 + }, + operationalInfos => { operationalInfo => 1 }, + overviewDoc => + { description => 1, overviewURL => 1, overviewURL => 1 }, + publisherAssertion => { + Signature => 1, + fromKey => 1, + keyedReference => 1, + toKey => 1 + }, + publisherAssertions => { publisherAssertion => 1 }, + registeredInfo => { businessInfos => 1, tModelInfos => 1 }, + relatedBusinessInfo => { + businessKey => 1, + description => 1, + name => 1, + sharedRelationships => 1 + }, + relatedBusinessInfos => { relatedBusinessInfo => 1 }, + relatedBusinessesList => { + businessKey => 1, + listDescription => 1, + relatedBusinessInfos => 1 + }, + result => { errInfo => 1 }, + save_binding => { authInfo => 1, bindingTemplate => 1 }, + save_business => { authInfo => 1, businessEntity => 1 }, + save_service => { authInfo => 1, businessService => 1 }, + save_tModel => { authInfo => 1, tModel => 1 }, + serviceDetail => { businessService => 1 }, + serviceInfo => { name => 1 }, + serviceInfos => { serviceInfo => 1 }, + serviceList => { listDescription => 1, serviceInfos => 1 }, + set_publisherAssertions => + { authInfo => 1, publisherAssertion => 1 }, + sharedRelationships => + { keyedReference => 1, publisherAssertion => 1 }, + tModel => { + categoryBag => 1, + description => 1, + Signature => 1, + identifierBag => 1, + name => 1, + overviewDoc => 1 + }, + tModelBag => { tModelKey => 1 }, + tModelDetail => { tModel => 1 }, + tModelInfo => { description => 1, name => 1 }, + tModelInfos => { tModelInfo => 1 }, + tModelInstanceDetails => { tModelInstanceInfo => 1 }, + tModelInstanceInfo => + { description => 1, instanceDetails => 1 }, + tModelList => { listDescription => 1, tModelInfos => 1 } + }, + ATTRIBUTES => { + accessPoint => { useType => 2 }, + address => + { sortCode => 2, tModelKey => 2, useType => 2, lang => 2 }, + addressLine => { keyName => 2, keyValue => 2 }, + assertionStatusItem => { completionStatus => 2 }, + bindingDetail => { truncated => 2 }, + bindingTemplate => { bindingKey => 2, serviceKey => 2 }, + businessDetail => { truncated => 2 }, + businessEntity => { businessKey => 2 }, + businessInfo => { businessKey => 2 }, + businessList => { truncated => 2 }, + businessService => { businessKey => 2, serviceKey => 2 }, + contact => { useType => 2 }, + description => { lang => 2 }, + discoveryURL => { useType => 2 }, + dispositionReport => { truncated => 2 }, + email => { useType => 2 }, + errInfo => { errCode => 2 }, + find_binding => + { listHead => 2, maxRows => 2, serviceKey => 2 }, + find_business => { listHead => 2, maxRows => 2 }, + find_relatedBusinesses => { listHead => 2, maxRows => 2 }, + find_service => + { businessKey => 2, listHead => 2, maxRows => 2 }, + find_tModel => { listHead => 2, maxRows => 2 }, + get_authToken => { cred => 2, userID => 2 }, + get_registeredInfo => { infoSelection => 2 }, + hostingRedirector => { bindingKey => 2 }, + keyedReference => + { keyName => 2, keyValue => 2, tModelKey => 2 }, + keyedReferenceGroup => { tModelKey => 2 }, + name => { lang => 2 }, + operationalInfo => { entityKey => 2 }, + operationalInfos => { truncated => 2 }, + overviewURL => { useType => 2 }, + personName => { lang => 2 }, + phone => { useType => 2 }, + registeredInfo => { truncated => 2 }, + relatedBusinessesList => { truncated => 2 }, + result => { errno => 2, keyType => 2 }, + serviceDetail => { truncated => 2 }, + serviceInfo => { businessKey => 2, serviceKey => 2 }, + serviceList => { truncated => 2 }, + sharedRelationships => { direction => 2 }, + tModel => { deleted => 2, tModelKey => 2 }, + tModelDetail => { truncated => 2 }, + tModelInfo => { tModelKey => 2 }, + tModelInstanceInfo => { tModelKey => 2 }, + tModelList => { truncated => 2 } + }, + WITHNAMES => [ + qw/accessPoint actualCount address addressLine assertionStatusItem assertionStatusReport authToken authorizedName bindingDetail bindingKey bindingTemplate bindingTemplates businessDetail businessEntity businessInfo businessInfos businessKey businessList businessService businessServices categoryBag completionStatus contact contacts created description discoveryURL discoveryURLs dispositionReport email entityKey errInfo findQualifier findQualifiers fromKey hostingRedirector identifierBag includeCount infoSelection instanceDetails instanceParms keyedReference keyedReferenceGroup keysOwned listDescription listHead modified modifiedIncludingChildren name nodeID operationalInfo operationalInfos overviewDoc overviewURL personName phone publisherAssertion publisherAssertions registeredInfo relatedBusinessInfo relatedBusinessInfos relatedBusinessesList result serviceDetail serviceInfo serviceInfos serviceKey serviceList sharedRelationships tModel tModelBag tModelDetail tModelInfo tModelInfos tModelInstanceDetails tModelInstanceInfo tModelKey tModelList toKey/ + ], + NAMESPACE => 'urn:uddi-org:api_v3', + GENERIC => undef, + }, + ); +} # ====================================================================== @@ -25,10 +715,11 @@ @ISA = qw(SOAP::SOM); -sub result { # result should point to immediate child of Body - my $self = shift; - my $result = '/Envelope/Body/[1]'; - ref $self or return $result; - defined $self->fault ? undef : $self->valueof($result); -}; +sub result +{ # result should point to immediate child of Body + my $self = shift; + my $result = '/Envelope/Body/[1]'; + ref $self or return $result; + defined $self->fault ? undef: $self->valueof($result); +} # ====================================================================== @@ -38,95 +729,139 @@ use Carp (); -use vars qw(@ISA $AUTOLOAD @EXPORT_OK %EXPORT_TAGS); +use vars qw(@ISA $AUTOLOAD); @ISA = qw(SOAP::Data); -my @elements = (with => qw/accessPoint address addressLine authInfo authToken bindingDetail bindingKey bindingTemplate bindingTemplates businessDetail businessDetailExt businessEntity businessEntityExt businessInfo businessInfos businessKey businessList businessService businessServices categoryBag contact contacts description discoveryURL discoveryURLs dispositionReport email errInfo findQualifier findQualifiers hostingRedirector identifierBag instanceDetails instanceParms keyValue keyedReference name overviewDoc overviewURL personName phone registeredInfo result serviceDetail serviceInfo serviceInfos serviceKey serviceList tModel tModelBag tModelDetail tModelInfo tModelInfos tModelInstanceDetails tModelInstanceInfo tModelKey tModelList uploadRegister/); -@EXPORT_OK = (@elements); -%EXPORT_TAGS = ('all' => [@EXPORT_OK]); - use overload fallback => 1, '""' => sub { shift->SUPER::value }; -use vars qw(%elements %attributes); -%elements = (get_serviceDetail=>{serviceKey=>1},find_tModel=>{categoryBag=>1,name=>1,identifierBag=>1,findQualifiers=>1},tModelInstanceInfo=>{instanceDetails=>1,description=>1},address=>{addressLine=>1},categoryBag=>{keyedReference=>1},save_binding=>{authInfo=>1,bindingTemplate=>1},businessEntity=>{categoryBag=>1,businessServices=>1,name=>1,description=>1,identifierBag=>1,discoveryURLs=>1,contacts=>1},businessInfos=>{businessInfo=>1},find_business=>{categoryBag=>1,name=>1,identifierBag=>1,discoveryURLs=>1,findQualifiers=>1,tModelBag=>1},get_bindingDetail=>{bindingKey=>1},identifierBag=>{keyedReference=>1},get_businessDetailExt=>{businessKey=>1},businessServices=>{businessService=>1},tModelInfo=>{name=>1},find_service=>{categoryBag=>1,name=>1,findQualifiers=>1,tModelBag=>1},dispositionReport=>{result=>1},authToken=>{authInfo=>1},get_tModelDetail=>{tModelKey=>1},delete_tModel=>{tModelKey=>1,authInfo=>1},bindingTemplate=>{tModelInstanceDetails=>1,accessPoint=>1,description=>1,hostingRedirector=>1},tModelDetail=>{tModel=>1},businessInfo=>{serviceInfos=>1,name=>1,description=>1},get_registeredInfo=>{authInfo=>1},businessEntityExt=>{businessEntity=>1},registeredInfo=>{businessInfos=>1,tModelInfos=>1},find_binding=>{findQualifiers=>1,tModelBag=>1},serviceInfo=>{name=>1},get_businessDetail=>{businessKey=>1},delete_business=>{businessKey=>1,authInfo=>1},discoveryURLs=>{discoveryURL=>1},businessDetail=>{businessEntity=>1},contacts=>{contact=>1},tModelInstanceDetails=>{tModelInstanceInfo=>1},tModelList=>{tModelInfos=>1},delete_service=>{serviceKey=>1,authInfo=>1},tModelInfos=>{tModelInfo=>1},serviceDetail=>{businessService=>1},tModel=>{categoryBag=>1,name=>1,description=>1,identifierBag=>1,overviewDoc=>1},businessList=>{businessInfos=>1},bindingTemplates=>{bindingTemplate=>1},validate_categorization=>{businessEntity=>1,tModel=>1,businessService=>1,keyValue=>1,tModelKey=>1},contact=>{email=>1,personName=>1,phone=>1,description=>1,address=>1},discard_authToken=>{authInfo=>1},overviewDoc=>{overviewURL=>1,description=>1},delete_binding=>{bindingKey=>1,authInfo=>1},serviceList=>{serviceInfos=>1},bindingDetail=>{bindingTemplate=>1},tModelBag=>{tModelKey=>1},businessDetailExt=>{businessEntityExt=>1},serviceInfos=>{serviceInfo=>1},save_tModel=>{uploadRegister=>1,tModel=>1,authInfo=>1},findQualifiers=>{findQualifier=>1},save_business=>{businessEntity=>1,uploadRegister=>1,authInfo=>1},instanceDetails=>{instanceParms=>1,description=>1,overviewDoc=>1},businessService=>{categoryBag=>1,name=>1,bindingTemplates=>1,description=>1},save_service=>{businessService=>1,authInfo=>1},result=>{errInfo=>1}); -%attributes = (get_serviceDetail=>{generic=>2},find_tModel=>{maxRows=>2,generic=>2},tModelInstanceInfo=>{tModelKey=>2},address=>{sortCode=>2,useType=>2},email=>{useType=>2},save_binding=>{generic=>2},businessEntity=>{authorizedName=>2,operator=>2,businessKey=>2},discoveryURL=>{useType=>2},find_business=>{maxRows=>2,generic=>2},get_bindingDetail=>{generic=>2},get_businessDetailExt=>{generic=>2},tModelInfo=>{tModelKey=>2},find_service=>{maxRows=>2,businessKey=>2,generic=>2},dispositionReport=>{truncated=>2,operator=>2,generic=>2},authToken=>{operator=>2,generic=>2},get_tModelDetail=>{generic=>2},bindingTemplate=>{serviceKey=>2,bindingKey=>2},delete_tModel=>{generic=>2},tModelDetail=>{truncated=>2,operator=>2,generic=>2},businessInfo=>{businessKey=>2},get_registeredInfo=>{generic=>2},registeredInfo=>{truncated=>2,operator=>2,generic=>2},phone=>{useType=>2},find_binding=>{maxRows=>2,serviceKey=>2,generic=>2},serviceInfo=>{serviceKey=>2,businessKey=>2},get_businessDetail=>{generic=>2},delete_business=>{generic=>2},businessDetail=>{truncated=>2,operator=>2,generic=>2},keyedReference=>{keyName=>2,keyValue=>2,tModelKey=>2},tModelList=>{truncated=>2,operator=>2,generic=>2},delete_service=>{generic=>2},serviceDetail=>{truncated=>2,operator=>2,generic=>2},tModel=>{authorizedName=>2,operator=>2,tModelKey=>2},businessList=>{truncated=>2,operator=>2,generic=>2},validate_categorization=>{generic=>2},contact=>{useType=>2},discard_authToken=>{generic=>2},delete_binding=>{generic=>2},serviceList=>{truncated=>2,operator=>2,generic=>2},bindingDetail=>{truncated=>2,operator=>2,generic=>2},hostingRedirector=>{bindingKey=>2},businessDetailExt=>{truncated=>2,operator=>2,generic=>2},get_authToken=>{userID=>2,generic=>2,cred=>2},save_tModel=>{generic=>2},errInfo=>{errCode=>2},save_business=>{generic=>2},accessPoint=>{URLType=>2},businessService=>{serviceKey=>2,businessKey=>2},save_service=>{generic=>2},result=>{keyType=>2,errno=>2}); - -sub new { - my $self = shift; - my $class = ref($self) || $self; - - unless (ref $self) { - $self = $class->SUPER::new(@_, type => 'uddi'); - } - return $self; -} - -sub with { - my $self = shift; - $self = (__PACKAGE__->can($self) || Carp::croak "Don't know what to do with '$self'")->() - unless ref $self && UNIVERSAL::isa($self => __PACKAGE__); - - my $name = $self->SUPER::name; - my @values; - while (@_) { - my $data = shift; - my($method, @value) = UNIVERSAL::isa($data => __PACKAGE__) - ? ($data->SUPER::name, $data->value) - : ($data, shift); - exists $attributes{$name}{$method} - ? $self->$method(@value) - : push(@values, ($self->can($method) || Carp::croak "Don't know what to do with '$method'")->(@value)); - } - $self->set_value([@values]); -} - -sub _compileit { - no strict 'refs'; - my $method = shift; - *$method = sub { - - # GENERATE element if no parameters: businessInfo() - return __PACKAGE__->SUPER::name($method) - if !@_ && exists $elements{$method}; - - die "Expected element (UDDI::Data) as parameter for $method()\n" - if !ref $_[0] && exists $elements{$method}; - - my $uddi = UNIVERSAL::isa($_[0] => __PACKAGE__); - - # MAKE ELEMENT: name('old') - return __PACKAGE__->SUPER::name($method => @_) - if !$uddi; - - my $name = $_[0]->SUPER::name; - - # GET/SET ATTRIBUTE: businessInfo->businessKey - return @_ > 1 - ? scalar($_[0]->attr->{$method} = $_[1], $_[0]) # SET - : __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method}) # GET - if exists $attributes{$name} && exists $attributes{$name}{$method}; - - # GET ELEMENT: businessInfos->businessInfo - my @elems = grep { - ref $_ && UNIVERSAL::isa($_ => __PACKAGE__) && $_->SUPER::name eq $method - } map {ref $_ eq 'ARRAY' ? @$_ : $_} $_[0]->value; - return wantarray? @elems : $elems[0] - if exists $elements{$name} && exists $elements{$name}{$method}; - - # MAKE ELEMENT: businessInfos(businessInfo('something')) - return __PACKAGE__->SUPER::name($method => @_) - if exists $elements{$method} && exists $elements{$method}{$name}; - - Carp::croak "Don't know what to do with '$method' and '$name' elements"; - } +sub _init +{ + use vars qw(@EXPORT_OK %EXPORT_TAGS); + @EXPORT_OK = ( with => @$UDDI::Constants::WITHNAMES ); + %EXPORT_TAGS = ( all => [@EXPORT_OK] ); + + use vars qw($elements $attributes); + $elements = $UDDI::Constants::ELEMENTS; + $attributes = $UDDI::Constants::ATTRIBUTES; +} + +sub new +{ + my $self = shift; + my $class = ref($self) || $self; + + unless ( ref $self ) + { + $self = $class->SUPER::new( @_, type => 'uddi' ); + } + return $self; +} + +sub with +{ + my $self = shift; + $self = + ( __PACKAGE__->can($self) + || Carp::croak "Don't know what to do with '$self'" )->() + unless ref $self && UNIVERSAL::isa( $self => __PACKAGE__ ); + + my $name = $self->SUPER::name; + my @values; + while (@_) + { + my $data = shift; + my ( $method, $attr, @value ) = + UNIVERSAL::isa( $data => __PACKAGE__ ) + ? ( $data->SUPER::name, $data->SUPER::attr, $data->SUPER::value ) + : ( $data, {}, shift ); + exists $attributes->{$name}{$method} + + # attribute + ? $self->$method(@value) + + # sub element + : push( + @values, + ( + $self->can($method) + || Carp::croak "Don't know what to do with '$method'" + )->(@value)->attr($attr) + ); + } + $self->set_value( [@values] ); +} + +sub _compileit +{ + no strict 'refs'; + my $method = shift; + *$method = sub { + + # GENERATE element if no parameters: businessInfo() + return __PACKAGE__->SUPER::name($method) + if !@_ && exists $elements->{$method}; + + die "Expected element (UDDI::Data) as parameter for $method()\n" + if !ref $_[0] && exists $elements->{$method}; + + # MAKE ELEMENT: name( [{attr => value},] 'old') + if ( !UNIVERSAL::isa( $_[0] => __PACKAGE__ ) ) + { + + # get optional list of attributes as a first parameter + my $attr = ref $_[0] eq 'HASH' ? shift @_ : {}; + return __PACKAGE__->SUPER::name( $method => @_ )->attr($attr); + } + + my $name = $_[0]->SUPER::name; + + if ( defined $name ) + { + + # GET/SET ATTRIBUTE: businessInfo->businessKey + return @_ > 1 + ? scalar( $_[0]->attr->{$method} = $_[1], $_[0] ) # SET + : __PACKAGE__->SUPER::name( + $method => $_[0]->attr->{$method} ) # GET + if exists $attributes->{$name} + && exists $attributes->{$name}{$method}; + + # GET ELEMENT: businessInfos->businessInfo + my @elems = grep { + ref $_ + && UNIVERSAL::isa( $_ => __PACKAGE__ ) + && $_->SUPER::name eq $method + } map { ref $_ eq 'ARRAY' ? @$_ : $_ } $_[0]->value; + return wantarray ? @elems : $elems[0] + if exists $elements->{$name} + && exists $elements->{$name}{$method}; + + # MAKE ELEMENT: businessInfos(businessInfo('something')) + return __PACKAGE__->SUPER::name( $method => @_ ) + if exists $elements->{$method} + && exists $elements->{$method}{$name}; + } + + # handle UDDI::Data->method() calls for those SOAP::Data methods + # that conflict with UDDI methods, like name() + if ( UNIVERSAL::can( $ISA[0] => $method ) ) + { + my $pkg = shift @_; + return eval "\$pkg->SUPER::$method(\@_)"; + } + + Carp::croak + "Don't know what to do with '$method' and '$name' elements"; + } } sub BEGIN { _compileit('name') } -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - _compileit($method); - goto &$AUTOLOAD; +sub AUTOLOAD +{ + my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 ); + return if $method eq 'DESTROY'; + + _compileit($method); + goto &$AUTOLOAD; } @@ -138,37 +873,52 @@ @ISA = qw(SOAP::Serializer); -sub new { - my $self = shift; - my $class = ref($self) || $self; - - unless (ref $self) { - $self = $class->SUPER::new( - attr => {}, - namespaces => { - $SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (), - }, - autotype => 0, - @_, - ); - } - return $self; -} - -use overload; # protect from stringification in UDDI::Data -sub gen_id { overload::StrVal($_[1]) =~ /\((0x\w+)\)/o; $1 } - -sub as_uddi { - my $self = shift; - my($value, $name, $type, $attr) = @_; - return $self->encode_array($value, $name, undef, $attr) if ref $value eq 'ARRAY'; - return $self->encode_hash($value, $name, undef, $attr) if ref $value eq 'HASH'; - [$name, {%{$attr || {}}}, ref $value ? ([$self->encode_object($value)], $self->gen_id($value)) : $value]; -} - -sub encode_array { - my $self = shift; - my $encoded = $self->SUPER::encode_array(@_); - delete $encoded->[1]->{SOAP::Utils::qualify($self->encprefix => 'arrayType')}; - return $encoded; +sub new +{ + my $self = shift; + my $class = ref($self) || $self; + + unless ( ref $self ) + { + $self = $class->SUPER::new( + attr => {}, + namespaces => { + $SOAP::Constants::PREFIX_ENV + ? ( $SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV ) + : (), + }, + autotype => 0, + @_, + ); + } + return $self; +} + +use overload; # protect from stringification in UDDI::Data +sub gen_id { overload::StrVal( $_[1] ) =~ /\((0x\w+)\)/o; $1 } + +sub as_uddi +{ + my $self = shift; + my ( $value, $name, $type, $attr ) = @_; + return $self->encode_array( $value, $name, undef, $attr ) + if ref $value eq 'ARRAY'; + return $self->encode_hash( $value, $name, undef, $attr ) + if ref $value eq 'HASH'; + [ + $name, + { %{ $attr || {} } }, + ref $value + ? ( [ $self->encode_object($value) ], $self->gen_id($value) ) + : $value + ]; +} + +sub encode_array +{ + my $self = shift; + my $encoded = $self->SUPER::encode_array(@_); + delete $encoded->[1] + ->{ SOAP::Utils::qualify( $self->encprefix => 'arrayType' ) }; + return $encoded; } @@ -180,22 +930,25 @@ @ISA = qw(SOAP::Deserializer); -sub decode_value { - my $self = shift; - my $ref = shift; - my($name, $attrs, $children, $value) = @$ref; - - # base class knows what to do with elements in SOAP namespace - return $self->SUPER::decode_value($ref) - if exists $attrs->{href} || - (SOAP::Utils::splitlongname($name))[0] eq $SOAP::Constants::NS_ENV; - - UDDI::Data - -> SOAP::Data::name($name) - -> attr($attrs) - -> set_value(ref $children && @$children ? map(scalar(($self->decode_object($_))[1]), @$children) : $value); -} - -sub deserialize { - bless shift->SUPER::deserialize(@_) => 'UDDI::SOM'; +sub decode_value +{ + my $self = shift; + my $ref = shift; + my ( $name, $attrs, $children, $value ) = @$ref; + + # base class knows what to do with elements in SOAP namespace + return $self->SUPER::decode_value($ref) + if exists $attrs->{href} + || ( SOAP::Utils::splitlongname($name) )[0] eq $SOAP::Constants::NS_ENV; + + UDDI::Data->SOAP::Data::name($name)->attr($attrs) + ->set_value( ref $children + && @$children + ? map( scalar( ( $self->decode_object($_) )[1] ), @$children ) + : $value ); +} + +sub deserialize +{ + bless shift->SUPER::deserialize(@_) => 'UDDI::SOM'; } @@ -209,79 +962,153 @@ @ISA = qw(SOAP::Lite Exporter); -BEGIN { # handle exports - %EXPORT_TAGS = ( - 'delete' => [qw/delete_binding delete_business delete_service delete_tModel/], - 'auth' => [qw/get_authToken discard_authToken get_registeredInfo/], - 'save' => [qw/save_binding save_business save_service save_tModel/], - 'validate' => [qw/validate_categorization/], - 'find' => [qw/find_binding find_business find_service find_tModel/], - 'get' => [qw/get_bindingDetail get_businessDetail get_businessDetailExt get_serviceDetail get_tModelDetail/], - ); - $EXPORT_TAGS{inquiry} = [map {@{$EXPORT_TAGS{$_}}} qw/find get/]; - $EXPORT_TAGS{publish} = [map {@{$EXPORT_TAGS{$_}}} qw/delete auth save validate/]; - $EXPORT_TAGS{all} = [map {@{$EXPORT_TAGS{$_}}} qw/inquiry publish/]; - Exporter::export_ok_tags('all'); -} - -sub new { - my $self = shift; - my $class = ref($self) || $self; - - unless (ref $self) { - $self = $class->SUPER::new( - on_action => sub {'""'}, - serializer => UDDI::Serializer->new, # register UDDI Serializer - deserializer => UDDI::Deserializer->new, # and Deserializer - @_, +BEGIN +{ # handle exports + %EXPORT_TAGS = ( + 'delete' => [ + qw/delete_binding delete_business delete_service + delete_tModel delete_publisherAssertions/ + ], + + # ^-------------------- v2/3 + 'auth' => [qw/get_authToken discard_authToken get_registeredInfo/], + 'save' => [ + qw/save_binding save_business save_service save_tModel + add_publisherAssertions set_publisherAssertions/ + ], + + # ^----------------- v2/3 ^----------------- v2/3 + 'validate' => [qw/validate_categorization validate_values/], + + # ^------------------- v1 ^------------v2 + 'find' => [ + qw/find_binding find_business find_service find_tModel + find_relatedBusinesses/ + ], + + # ^---------------- v2/3 + 'get' => [ + qw/get_bindingDetail get_businessDetail get_businessDetailExt + get_serviceDetail get_tModelDetail + get_assertionStatusReport get_publisherAssertions/ + ], + + # ^------------------- v2/3 ^----------------- v2/3 ); - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { - return shift->call($method => @_) if UNIVERSAL::isa($_[0] => __PACKAGE__); - my $som = (__PACKAGE__->self || Carp::croak "Method call on unspecified object. Died")->call($method => @_); - UNIVERSAL::isa($som => 'SOAP::SOM') ? $som->result : $som; - }; - goto &$AUTOLOAD; -} - -sub call { SOAP::Trace::trace('()'); - my $self = shift; - my $method = shift; - my @parameters; - my $attr = ref $_[0] eq 'HASH' ? shift() : {}; - while (@_) { - push(@parameters, UNIVERSAL::isa($_[0] => 'UDDI::Data') - ? shift : SOAP::Data->name(shift, shift)); - } - my $message = SOAP::Data - -> name($method => \SOAP::Data->value(@parameters)) - -> attr({xmlns=>'urn:uddi-org:api', generic => '1.0', %$attr}); - - my $serializer = $self->serializer; - $serializer->on_nonserialized($self->on_nonserialized); - - my $respond = $self->transport->send_receive( - endpoint => $self->endpoint, - action => $self->on_action->($self->uri), - envelope => $serializer->envelope(freeform => $message), - encoding => $serializer->encoding, - ); - - return $respond if $self->outputxml; - - unless ($self->transport->is_success) { - my $result = eval { $self->deserializer->deserialize($respond) } if $respond; - return $self->on_fault->($self, $@ ? $respond : $result) || $result; - } - - return unless $respond; # nothing to do for one-ways - return $self->deserializer->deserialize($respond); + $EXPORT_TAGS{inquiry} = [ map { @{ $EXPORT_TAGS{$_} } } qw/find get/ ]; + $EXPORT_TAGS{publish} = + [ map { @{ $EXPORT_TAGS{$_} } } qw/delete auth save validate/ ]; + $EXPORT_TAGS{all} = [ map { @{ $EXPORT_TAGS{$_} } } qw/inquiry publish/ ]; + Exporter::export_ok_tags('all'); +} + +my $uddiversion; + +sub uddiversion +{ + my $self = shift; + my $version = shift or return $uddiversion; + + die qq!Wrong UDDI version. Supported versions: @{[ + join ", ", keys %UDDI::Constants::UDDI_VERSIONS]}\n! + unless defined $UDDI::Constants::UDDI_VERSIONS{$version}; + + foreach ( keys %{ $UDDI::Constants::UDDI_VERSIONS{$version} } ) + { + eval +"\$UDDI::Constants::$_ = \$UDDI::Constants::UDDI_VERSIONS{$version}->{$_}" + or die; + } + + UDDI::Data->_init; + + $uddiversion = $version; + $self; +} + +BEGIN { UDDI::Lite->uddiversion(1) } + +sub new +{ + my $self = shift; + my $class = ref($self) || $self; + + unless ( ref $self ) + { + $self = $class->SUPER::new( + on_action => sub { '""' }, + serializer => UDDI::Serializer->new, # register UDDI Serializer + deserializer => UDDI::Deserializer->new, # and Deserializer + @_, + ); + } + return $self; +} + +sub AUTOLOAD +{ + my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 ); + return if $method eq 'DESTROY'; + + no strict 'refs'; + *$AUTOLOAD = sub { + return shift->call( $method => @_ ) + if UNIVERSAL::isa( $_[0] => __PACKAGE__ ); + my $som = + ( __PACKAGE__->self + || Carp::croak "Method call on unspecified object. Died" ) + ->call( $method => @_ ); + UNIVERSAL::isa( $som => 'SOAP::SOM' ) ? $som->result : $som; + }; + goto &$AUTOLOAD; +} + +sub call +{ + SOAP::Trace::trace('()'); + my $self = shift; + my $method = shift; + my @parameters; + my $attr = ref $_[0] eq 'HASH' ? shift() : {}; + while (@_) + { + push( @parameters, + UNIVERSAL::isa( $_[0] => 'UDDI::Data' ) + ? shift + : SOAP::Data->name( shift, shift ) ); + } + my $message = + SOAP::Data->name( $method => \SOAP::Data->value(@parameters) )->attr( + { + xmlns => $UDDI::Constants::NAMESPACE, + ( + defined $UDDI::Constants::GENERIC + ? ( generic => $UDDI::Constants::GENERIC ) + : () + ), + %$attr + } + ); + + my $serializer = $self->serializer; + $serializer->on_nonserialized( $self->on_nonserialized ); + + my $respond = $self->transport->send_receive( + endpoint => $self->endpoint, + action => $self->on_action->( $self->uri ), + envelope => $serializer->envelope( freeform => $message ), + encoding => $serializer->encoding, + ); + + return $respond if $self->outputxml; + + unless ( $self->transport->is_success ) + { + my $result = eval { $self->deserializer->deserialize($respond) } + if $respond; + return $self->on_fault->( $self, $@ ? $respond : $result ) || $result; + } + + return unless $respond; # nothing to do for one-ways + return $self->deserializer->deserialize($respond); } @@ -452,4 +1279,8 @@ =back +To change to UDDI Version 2, use the following pragma: + + use UDDI::Lite uddiversion => 2; + =head2 UDDI::Data @@ -629,5 +1460,5 @@ =head1 COPYRIGHT -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. +Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved. This library is free software; you can redistribute it and/or modify Index: /trunk/extlib/Net/OpenID/IndirectMessage.pm =================================================================== --- /trunk/extlib/Net/OpenID/IndirectMessage.pm (revision 2758) +++ /trunk/extlib/Net/OpenID/IndirectMessage.pm (revision 3531) @@ -75,5 +75,5 @@ # but act like it's a normal 1.1 request. # We do this by just pretending that ns wasn't set at all. - if ($ns eq 'http://openid.net/signon/1.1' || $ns eq 'http://openid.net/signon/1.0') { + if ($ns && ($ns eq 'http://openid.net/signon/1.1' || $ns eq 'http://openid.net/signon/1.0')) { $ns = undef; } Index: /trunk/extlib/Net/OpenID/VerifiedIdentity.pm =================================================================== --- /trunk/extlib/Net/OpenID/VerifiedIdentity.pm (revision 2183) +++ /trunk/extlib/Net/OpenID/VerifiedIdentity.pm (revision 3531) Index: /trunk/extlib/Net/OpenID/ClaimedIdentity.pm =================================================================== --- /trunk/extlib/Net/OpenID/ClaimedIdentity.pm (revision 2183) +++ /trunk/extlib/Net/OpenID/ClaimedIdentity.pm (revision 3531) Index: /trunk/extlib/Net/OpenID/URIFetch.pm =================================================================== --- /trunk/extlib/Net/OpenID/URIFetch.pm (revision 3531) +++ /trunk/extlib/Net/OpenID/URIFetch.pm (revision 3531) @@ -0,0 +1,183 @@ +#!/usr/bin/perl + +=head1 NAME + +Net::OpenID::URIFetch - fetch and cache content from HTTP URLs + +=head1 DESCRIPTION + +This is roughly based on Ben Trott's URI::Fetch module, but +URI::Fetch doesn't cache enough headers that Yadis can be implemented +with it, so this is a lame copy altered to allow Yadis support. + +Hopefully one day URI::Fetch can be modified to do what we need and +this can go away. + +This module is tailored to the needs of Net::OpenID::Consumer and probably +isn't much use outside of it. See URI::Fetch for a more general module. + +=cut + +package Net::OpenID::URIFetch; + +use HTTP::Request; +use HTTP::Status; +use strict; +use warnings; +use Carp; + +our $HAS_ZLIB; +BEGIN { + $HAS_ZLIB = eval "use Compress::Zlib (); 1;"; +} + +use constant URI_OK => 200; +use constant URI_MOVED_PERMANENTLY => 301; +use constant URI_NOT_MODIFIED => 304; +use constant URI_GONE => 410; + +sub fetch { + my ($class, $uri, $consumer, $content_hook) = @_; + + if ($uri eq 'x-xrds-location') { + Carp::confess("Buh?"); + } + + my $ua = $consumer->ua; + my $cache = $consumer->cache; + my $ref; + + # By prefixing the cache key, we can ensure we won't + # get left-over cache items from older versions of Consumer + # that used URI::Fetch. + my $cache_key = 'URIFetch:'.$uri; + + if ($cache) { + if (my $blob = $cache->get($cache_key)) { + $ref = Storable::thaw($blob); + } + } + + # We just serve anything from the last 60 seconds right out of the cache, + # thus avoiding doing several requests to the same URL when we do + # Yadis, then HTML discovery. + # TODO: Make this tunable? + if ($ref && $ref->{CacheTime} > (time() - 60)) { + $consumer->_debug("Cache HIT for $uri"); + return Net::OpenID::URIFetch::Response->new( + status => 200, + content => $ref->{Content}, + headers => $ref->{Headers}, + final_uri => $ref->{FinalURI}, + ); + } + else { + $consumer->_debug("Cache MISS for $uri"); + } + + my $req = HTTP::Request->new(GET => $uri); + if ($HAS_ZLIB) { + $req->header('Accept-Encoding', 'gzip'); + } + if ($ref) { + if (my $etag = ($ref->{Headers}->{etag})) { + $req->header('If-None-Match', $etag); + } + if (my $ts = ($ref->{Headers}->{'last-modified'})) { + $req->if_modified_since($ts); + } + } + + my $res = $ua->request($req); + + # There are only a few headers that OpenID/Yadis care about + my @useful_headers = qw(last-modified etag content-type x-yadis-location x-xrds-location); + + my %response_fields; + + if ($res->code == HTTP::Status::RC_NOT_MODIFIED()) { + $consumer->_debug("Server says it's not modified. Serving from cache."); + return Net::OpenID::URIFetch::Response->new( + status => 200, + content => $ref->{Content}, + headers => $ref->{Headers}, + final_uri => $ref->{FinalURI}, + ); + } + else { + my $content = $res->content; + my $final_uri = $res->request->uri->as_string(); + my $final_cache_key = "URIFetch:".$final_uri; + + if ($res->content_encoding && $res->content_encoding eq 'gzip') { + $content = Compress::Zlib::memGunzip($content); + } + + if ($content_hook) { + $content_hook->(\$content); + } + + my $headers = {}; + foreach my $k (@useful_headers) { + $headers->{$k} = $res->header($k); + } + + my $ret = Net::OpenID::URIFetch::Response->new( + status => $res->code, + content => $content, + headers => $headers, + final_uri => $final_uri, + ); + + if ($cache && $res->code == 200) { + my $cache_data = { + Headers => $ret->headers, + Content => $ret->content, + CacheTime => time(), + FinalURI => $final_uri, + }; + my $cache_blob = Storable::freeze($cache_data); + $cache->set($final_cache_key, $cache_blob); + $cache->set($cache_key, $cache_blob); + } + + return $ret; + } + +} + +package Net::OpenID::URIFetch::Response; + +sub new { + my ($class, %opts) = @_; + + my $self = {}; + $self->{final_uri} = delete($opts{final_uri}); + $self->{status} = delete($opts{status}); + $self->{content} = delete($opts{content}); + $self->{headers} = delete($opts{headers}); + + return bless $self, $class; +} + +sub final_uri { + return $_[0]->{final_uri}; +} + +sub status { + return $_[0]->{status}; +} + +sub content { + return $_[0]->{content}; +} + +sub headers { + return $_[0]->{headers}; +} + +sub header { + return $_[0]->{headers}{lc($_[1])}; +} + +1; Index: /trunk/extlib/Net/OpenID/Yadis.pm =================================================================== --- /trunk/extlib/Net/OpenID/Yadis.pm (revision 2758) +++ /trunk/extlib/Net/OpenID/Yadis.pm (revision 3531) @@ -8,5 +8,5 @@ use base qw(Exporter); use Carp (); -use URI::Fetch 0.02; +use Net::OpenID::URIFetch; use XML::Simple; use Net::OpenID::Yadis::Service; @@ -15,5 +15,4 @@ use constant { - YR_HEAD => 0, YR_GET => 1, YR_XRDS => 2, @@ -21,9 +20,8 @@ use fields ( - 'cache', # the Cache object sent to URI::Fetch - '_ua', # Custom LWP::UserAgent instance to use 'last_errcode', # last error code we got 'last_errtext', # last error code we got 'debug', # debug flag or codeblock + 'consumer', # consumer object 'identity_url', # URL to be identified 'xrd_url', # URL of XRD file @@ -36,6 +34,5 @@ my %opts = @_; - $self->ua ( delete $opts{ua} ); - $self->cache ( delete $opts{cache} ); + $self->consumer(delete($opts{consumer})); $self->{debug} = delete $opts{debug}; @@ -46,9 +43,9 @@ } -sub cache { &_getset; } +sub consumer { &_getset; } + sub identity_url { &_getset; } sub xrd_url { &_getset; } sub xrd_objects { _pack_array(&_getset); } -sub _ua { &_getset; } sub _getset { my $self = shift; @@ -112,40 +109,27 @@ } -sub ua { - my $self = shift; - my $ua = shift if @_; - Carp::croak("Too many parameters") if @_; - - if (($ua) || (!$self->{_ua})) { - $self->{_ua} = Net::OpenID::Yadis::UA->new($ua); - } - - $self->{_ua}->{'ua'}; -} - sub _get_contents { my $self = shift; - my ($url, $final_url_ref, $content_ref, $headers_ref) = @_; - $final_url_ref ||= do { my $dummy; \$dummy; }; - - my $ures = URI::Fetch->fetch($url, - UserAgent => $self->_ua, - Cache => $self->_ua->force_head ? undef : $self->cache, - ContentAlterHook => sub {my $htmlref = shift;$$htmlref =~ s/_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr); - - if ($ures->status == URI::Fetch::URI_GONE()) { - return $self->_fail("url_gone"); - } - - my $res = $ures->http_response; - - $$final_url_ref = $res->request->uri->as_string; - $res->headers->scan(sub{$headers_ref->{lc($_[0])} ||= $_[1];}); - $$content_ref = $ures->content; - - return 1; + + my $alter_hook = sub { + my $htmlref = shift; + $$htmlref =~ s/fetch($url, $self->consumer, $alter_hook); + + if ($res) { + $$final_url_ref = $res->final_uri; + my $headers = $res->headers; + foreach my $k (keys %$headers) { + $headers_ref->{$k} ||= $headers->{$k}; + } + $$content_ref = $res->content; + return 1; + } + else { + return undef; + } } @@ -153,5 +137,5 @@ my $self = shift; my $url = shift or return $self->_fail("empty_url"); - my $count = shift || YR_HEAD; # $count = YR_HEAD:HEAD request YR_GET:GET request YR_XRDS:XRDS request + my $count = shift || YR_GET; Carp::croak("Too many parameters") if @_; @@ -164,6 +148,4 @@ my %headers; - $self->_ua->force_head(1) if ($count == YR_HEAD); - my $xrd; $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return; @@ -173,12 +155,13 @@ my $doc_url; if (($doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}) && ($count < YR_XRDS)) { - return $self->discover($doc_url,YR_XRDS); - } elsif ($headers{'content-type'} eq 'application/xrds+xml') { - return $self->discover($final_url,YR_XRDS) if ((!$xrd) && ($count == YR_HEAD)); + return $self->discover($doc_url, YR_XRDS); + } + elsif ( (split /;\s*/, $headers{'content-type'})[0] eq 'application/xrds+xml') { $self->xrd_url($final_url); return $self->parse_xrd($xrd); } - - return $count == YR_HEAD ? $self->discover($final_url,YR_GET) : $self->_fail($count == YR_GET ? "no_yadis_document" :"too_many_hops"); + else { + return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops"); + } } @@ -225,5 +208,5 @@ my $code_ref; my $protocol = undef; - + Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects; @@ -258,50 +241,4 @@ } -package Net::OpenID::Yadis::UA; - -# This module is decolation module to LWP::UserAgent. -# This add application/xrds+xml HTTP header and GET method to request object used in URI::Fetch. - -use strict; -use warnings; -use LWP::UserAgent; -use vars qw($AUTOLOAD $lwpclass); - -BEGIN { - eval "use LWPx::ParanoidAgent;"; - $lwpclass = $@ ? "LWP::UserAgent" : "LWPx::ParanoidAgent"; -} - -sub new { - my $class = shift; - my $ua = shift; - unless ($ua) { - $ua = $lwpclass->new; - $ua->timeout(10); - } - bless {ua => $ua,force_head => 0},$class; -} - -sub request { - my $self = shift; - my $req = shift; - $req->header('Accept' => 'application/xrds+xml'); - $req->method($self->force_head ? "HEAD" : "GET"); - $self->force_head(0); - $self->{'ua'}->request($req); -} - -sub force_head { - $_[0]->{'force_head'} = $_[1] if defined($_[1]); - $_[0]->{'force_head'}; -} - -sub AUTOLOAD { - my $self = shift; - return if $AUTOLOAD =~ /::DESTROY$/; - $AUTOLOAD =~ s/.*:://; - $self->{'ua'}->$AUTOLOAD(@_); -} - 1; __END__ @@ -316,7 +253,6 @@ my $disc = Net::OpenID::Yadis->new( - ua => $ua, # LWP::UserAgent (or similar) object - cache => $cache # Cache object - ); + consumer => $consumer, # Net::OpenID::Consumer object + ); my $xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err); @@ -351,4 +287,7 @@ but was forked and simplified for inclusion in the core OpenID Consumer package. +This simplified version is tailored for the needs of Net::OpenID::Consumer; for other +uses, L is probably a better choice. + =head1 CONSTRUCTOR @@ -359,6 +298,6 @@ my $disc = Net::OpenID::Yadis->new([ %opts ]); -You can set the C and C in the constructor. See the corresponding -method descriptions below. +You can set the C in the constructor. See the corresponding +method description below. =back @@ -370,18 +309,12 @@ =over 4 -=item C - -If you set this value to option argument of discover method, module check Yadis -URL start from HTTP HEAD request. - =item C -If you set this, module check Yadis URL start from HTTP GET request. +If you set this, module check Yadis URL start from HTTP GET request. This is the default. =item C -If you set this, this module consider Yadis URL as Yadis Resource Descriptor -URL. -If not so, error returns. +If you set this, this module consider Yadis URL as Yadis Resource Descriptor URL. +If not so, an error is returned. =back @@ -391,24 +324,9 @@ =over 4 -=item $disc->B($user_agent) - -=item $disc->B - -Getter/setter for the LWP::UserAgent (or subclass) instance which will -be used when web donwloads are needed. It's highly recommended that -you use LWPx::ParanoidAgent, or at least read its documentation so -you're aware of why you should care. - -=item $disc->B($cache) - -=item $disc->B - -Getter/setter for the optional (but recommended!) cache instance you -want to use for storing fetched parts of pages. - -The $cache object can be anything that has a -Eget($key) and --Eset($key,$value) methods. See L for more -information. This cache object is just passed to L -directly. +=item $disc->B($consumer) + +=item $disc->B + +Get or set the Net::OpenID::Consumer object that this object is associated with. =item $disc->B($url,[$request_method]) @@ -525,4 +443,6 @@ L +L + =head1 AUTHORS Index: /trunk/extlib/Net/OpenID/Consumer.pm =================================================================== --- /trunk/extlib/Net/OpenID/Consumer.pm (revision 2758) +++ /trunk/extlib/Net/OpenID/Consumer.pm (revision 3531) @@ -4,5 +4,5 @@ use Carp (); use LWP::UserAgent; -use URI::Fetch 0.02; +use Storable; ############################################################################ @@ -10,8 +10,8 @@ use vars qw($VERSION); -$VERSION = "0.14"; +$VERSION = "1.03"; use fields ( - 'cache', # the Cache object sent to URI::Fetch + 'cache', # a Cache object to store HTTP responses and associations 'ua', # LWP::UserAgent instance to use 'args', # how to get at your args @@ -30,4 +30,5 @@ use Net::OpenID::Yadis; use Net::OpenID::IndirectMessage; +use Net::OpenID::URIFetch; use MIME::Base64 (); @@ -204,26 +205,14 @@ } - sub _get_url_contents { my Net::OpenID::Consumer $self = shift; - my ($url, $final_url_ref, $hook) = @_; + my ($url, $final_url_ref, $hook) = @_; $final_url_ref ||= do { my $dummy; \$dummy; }; - my $ures = URI::Fetch->fetch($url, - UserAgent => $self->ua, - Cache => $self->cache, - ContentAlterHook => $hook, - ) - or return $self->_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr); - - # who actually uses HTTP gone response status? uh, nobody. - if ($ures->status == URI::Fetch::URI_GONE()) { - return $self->_fail("url_gone", "URL is no longer available"); - } - - my $res = $ures->http_response; - $$final_url_ref = $res->request->uri->as_string; - - return $ures->content; + my $res = Net::OpenID::URIFetch->fetch($url, $self, $hook); + + $$final_url_ref = $res->final_uri; + + return $res ? $res->content : undef; } @@ -241,6 +230,5 @@ }; - my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) or - return; + my $doc = $self->_get_url_contents($url, $final_url_ref, $trim_hook) || ''; # find content of document (notably: the first head, if an attacker @@ -403,4 +391,6 @@ my $primary_only = delete $opts{primary_only} ? 1 : 0; + my $force_version = delete $opts{force_version}; + Carp::croak("Unknown option(s) ".join(', ', keys(%opts))) if %opts; @@ -429,5 +419,5 @@ # First we Yadis service discovery - my $yadis = Net::OpenID::Yadis->new(ua => $self->{ua}); + my $yadis = Net::OpenID::Yadis->new(consumer => $self); if ($yadis->discover($url)) { # FIXME: Currently we don't ever do _find_semantic_info in the Yadis @@ -484,4 +474,5 @@ if (@versions) { foreach my $version (@versions) { + next if defined($force_version) && $force_version != $version; foreach my $uri (@$service_uris) { push @discovered_endpoints, { @@ -531,22 +522,26 @@ if ($sem_info) { if ($sem_info->{"openid2.provider"}) { - push @discovered_endpoints, { - uri => $sem_info->{"openid2.provider"}, - version => 2, - final_url => $final_url, - delegate => $sem_info->{"openid2.local_id"}, - sem_info => $sem_info, - mechanism => "HTML", - }; + unless (defined($force_version) && $force_version != 2) { + push @discovered_endpoints, { + uri => $sem_info->{"openid2.provider"}, + version => 2, + final_url => $final_url, + delegate => $sem_info->{"openid2.local_id"}, + sem_info => $sem_info, + mechanism => "HTML", + }; + } } if ($sem_info->{"openid.server"}) { - push @discovered_endpoints, { - uri => $sem_info->{"openid.server"}, - version => 1, - final_url => $final_url, - delegate => $sem_info->{"openid.delegate"}, - sem_info => $sem_info, - mechanism => "HTML", - }; + unless (defined($force_version) && $force_version != 1) { + push @discovered_endpoints, { + uri => $sem_info->{"openid.server"}, + version => 1, + final_url => $final_url, + delegate => $sem_info->{"openid.delegate"}, + sem_info => $sem_info, + mechanism => "HTML", + }; + } } } @@ -652,10 +647,39 @@ my $signed = $self->message("signed"); + my $possible_endpoints; + my $server; + my $claimed_identity; + my $real_ident; if ($self->_message_version == 1) { $real_ident = $self->args("oic.identity") || $a_ident; + + # In version 1, we have to assume that the primary server + # found during discovery is the one sending us this message. + $possible_endpoints = $self->_discover_acceptable_endpoints($real_ident, force_version => 1); + + if ($possible_endpoints && @$possible_endpoints) { + $possible_endpoints = [ $possible_endpoints->[0] ]; + $server = $possible_endpoints->[0]{uri}; + } + else { + # We just fall out of here and bail out below for having no endpoints. + } } else { $real_ident = $self->message("claimed_id") || $a_ident; + + # In version 2, the OP tells us its URL. + $server = $self->message("op_endpoint"); + $possible_endpoints = $self->_discover_acceptable_endpoints($real_ident, force_version => 2); + + # FIXME: It kinda sucks that the above will always do both Yadis and HTML discovery, even though + # in most cases only one will be in use. + } + + $self->_debug("Server is $server"); + + unless ($possible_endpoints && @$possible_endpoints) { + return $self->_fail("no_identity_server"); } @@ -678,39 +702,68 @@ } - my $claimed_identity = $self->claimed_identity($real_ident); - return $self->_fail("no_identity_server") unless $claimed_identity; - - # NOTE: Currently we're expecting the "primary" OP -- that is, the one that "wins" - # when we do discovery -- to be the one that sends the response. Since we currently - # don't support falling back to other providers in the XRD case, this should always - # be a valid assumption unless this assersion request is unsolicited. - # We'll also fail if the identifier's provider priorities are twiddled between - # request and response, but that's unlikely enough that we're just going to ignore it. - - my $final_url = $claimed_identity->claimed_url; - - # OpenID 2.0 wants us to exclude the fragment part of the URL when doing equality checks - my $a_ident_nofragment = $a_ident; - my $real_ident_nofragment = $real_ident; - my $final_url_nofragment = $final_url; - if ($self->_message_version >= 2) { - $a_ident_nofragment =~ s/\#.*$//x; - $real_ident_nofragment =~ s/\#.*$//x; - $final_url_nofragment =~ s/\#.*$//x; - } - return $self->_fail("unexpected_url_redirect") unless $final_url_nofragment eq $real_ident_nofragment; - - my $server = $claimed_identity->identity_server; - - # Protocol version must match - return $self->_fail("protocol_version_incorrect") unless $claimed_identity->protocol_version == $self->_message_version; - - # if openid.delegate was used, check that it was done correctly - if ($a_ident_nofragment ne $real_ident_nofragment) { - my $delegate = $claimed_identity->delegated_url; + my $last_error = undef; + + foreach my $endpoint (@$possible_endpoints) { + my $final_url = $endpoint->{final_url}; + my $endpoint_uri = $endpoint->{uri}; + my $delegate = $endpoint->{delegate}; + + my $error = sub { + $self->_debug("$endpoint_uri not acceptable: ".$_[0]); + $last_error = $_[0]; + }; + + # The endpoint_uri must match our $server + if ($endpoint_uri ne $server) { + $error->("server_not_allowed"); + next; + } + + # OpenID 2.0 wants us to exclude the fragment part of the URL when doing equality checks my $a_ident_nofragment = $a_ident; - $a_ident_nofragment =~ s/\#.*$//; - $self->_debug("verified_identity: verifying delegate $delegate for $a_ident_nofragment"); - return $self->_fail("bogus_delegation") unless $delegate eq $a_ident; + my $real_ident_nofragment = $real_ident; + my $final_url_nofragment = $final_url; + if ($self->_message_version >= 2) { + $a_ident_nofragment =~ s/\#.*$//x; + $real_ident_nofragment =~ s/\#.*$//x; + $final_url_nofragment =~ s/\#.*$//x; + } + unless ($final_url_nofragment eq $real_ident_nofragment) { + $error->("unexpected_url_redirect"); + next; + } + + # Protocol version must match + unless ($endpoint->{version} == $self->_message_version) { + $error->("protocol_version_incorrect"); + next; + } + + # if openid.delegate was used, check that it was done correctly + if ($a_ident_nofragment ne $real_ident_nofragment) { + unless ($delegate eq $a_ident_nofragment) { + $error->("bogus_delegation"); + next; + } + } + + # If we've got this far then we've found the right endpoint. + + $claimed_identity = Net::OpenID::ClaimedIdentity->new( + identity => $endpoint->{final_url}, + server => $endpoint->{uri}, + consumer => $self, + delegate => $endpoint->{delegate}, + protocol_version => $endpoint->{version}, + semantic_info => $endpoint->{sem_info}, + ); + last; + + } + + unless ($claimed_identity) { + # We failed to find a good endpoint in the above loop, so + # lets bail out. + return $self->_fail($last_error); } @@ -721,4 +774,25 @@ my %signed_fields; # key (without openid.) -> value + + # Auth 2.0 requires certain keys to be signed. + if ($self->_message_version >= 2) { + my %signed_fields = map {$_ => 1} split /,/, $signed; + my %unsigned_fields; + # these fields must be signed unconditionally + foreach my $f (qw/op_endpoint return_to response_nonce assoc_handle/) { + $unsigned_fields{$f}++ if !$signed_fields{$f}; + } + # these fields must be signed if present + foreach my $f (qw/claimed_id identity/) { + next unless $self->args("openid.$f"); + $unsigned_fields{$f}++ if !$signed_fields{$f}; + } + if (%unsigned_fields) { + return $self->_fail( + "unsigned_field", + "Field(s) must be signed: " . join(", ", keys %unsigned_fields) + ); + } + } if ($assoc) { @@ -1347,4 +1421,10 @@ This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND. +=head1 MAILING LIST + +The Net::OpenID family of modules has a mailing list powered +by Google Groups. For more information, see +http://groups.google.com/group/openid-perl . + =head1 SEE ALSO Index: /trunk/extlib/Net/OpenID/Association.pm =================================================================== --- /trunk/extlib/Net/OpenID/Association.pm (revision 2183) +++ /trunk/extlib/Net/OpenID/Association.pm (revision 3531) Index: /trunk/extlib/XML/Parser/Lite.pm =================================================================== --- /trunk/extlib/XML/Parser/Lite.pm (revision 1098) +++ /trunk/extlib/XML/Parser/Lite.pm (revision 3531) @@ -1,9 +1,10 @@ # ====================================================================== # -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com) +# Copyright (C) 2000-2007 Paul Kulchenko (paulclinger@yahoo.com) +# Copyright (C) 2008 Martin Kutter (martin.kutter@fen-net.de) # SOAP::Lite is free software; you can redistribute it # and/or modify it under the same terms as Perl itself. # -# $Id: Lite.pm,v 1.2 2005/02/22 01:47:42 byrnereese Exp $ +# $Id: Lite.pm 249 2008-05-05 20:35:05Z kutterma $ # # ====================================================================== @@ -13,137 +14,197 @@ use strict; use vars qw($VERSION); -#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: $ =~ /-(\d+)_([\d_]+)/); -$VERSION = '0.65_3'; - -sub new { - my $self = shift; - my $class = ref($self) || $self; - return $self if ref $self; - - $self = bless {} => $class; - my %parameters = @_; - $self->setHandlers(); # clear first - $self->setHandlers(%{$parameters{Handlers} || {}}); - return $self; +use version; $VERSION = qv('0.710.05'); + +sub new { + my $class = shift; + + return $class if ref $class; + my $self = bless {} => $class; + + my %parameters = @_; + $self->setHandlers(); # clear first + $self->setHandlers(%{$parameters{Handlers} || {}}); + + return $self; } sub setHandlers { - my $self = shift; - no strict 'refs'; local $^W; - # clear all handlers if called without parameters - unless (@_) { foreach (qw(Start End Char Final Init)) { *$_ = sub {} } } - while (@_) { my($name => $func) = splice(@_, 0, 2); *$name = defined $func ? $func : sub {} } - return $self; -} - -sub regexp { - my $patch = shift || ''; - my $package = __PACKAGE__; - - # This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html - - # Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions", - # Technical Report TR 1998-17, School of Computing Science, Simon Fraser University, November, 1998. - # Copyright (c) 1998, Robert D. Cameron. - # The following code may be freely used and distributed provided that - # this copyright and citation notice remains intact and that modifications - # or additions are clearly identified. - - my $TextSE = "[^<]+"; - my $UntilHyphen = "[^-]*-"; - my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-"; - my $CommentCE = "$Until2Hyphens>?"; - my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+"; - my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>"; - my $S = "[ \\n\\t\\r]+"; - my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]"; - my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]"; - my $Name = "(?:$NameStrt)(?:$NameChar)*"; - my $QuoteSE = "\"[^\"]*\"|'[^']*'"; - my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*"; - my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>"; - my $S1 = "[\\n\\r\\t ]"; - my $UntilQMs = "[^?]*\\?+"; - my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>"; - my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S"; - my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?"; - my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?"; - my $PI_CE = "$Name(?:$PI_Tail)?"; - - # these expressions were modified for backtracking and events - my $EndTagCE = "($Name)(?{${package}::end(\$2)})(?:$S)?>"; - my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'"; - my $ElemTagCE = "($Name)(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)(?{[\@{\$^R||[]},\$4=>defined\$5?\$5:\$6]}))*(?:$S)?(/)?>(?{${package}::start(\$3,\@{\$^R||[]})})(?{\${7} and ${package}::end(\$3)})"; - my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)"; - - # Next expression is under "black magic". - # Ideally it should be '($TextSE)(?{${package}::char(\$1)})|$MarkupSPE', - # but it doesn't work under Perl 5.005 and only magic with - # (?:....)?? solved the problem. - # I would appreciate if someone let me know what is the right thing to do - # and what's the reason for all this magic. - # Seems like a problem related to (?:....)? rather than to ?{} feature. - # Tests are in t/31-xmlparserlite.t if you decide to play with it. - "(?:($TextSE)(?{${package}::char(\$1)}))$patch|$MarkupSPE"; -} - -sub compile { local $^W; - # try regexp as it should be, apply patch if doesn't work - foreach (regexp(), regexp('??')) { - eval qq{sub parse_re { use re "eval"; 1 while \$_[0] =~ m{$_}go }; 1} or die; - last if eval { parse_re('bar'); 1 } - }; - - *compile = sub {}; + my $self = shift; + + # allow symbolic refs, avoid "subroutine redefined" warnings + no strict 'refs'; local $^W; + # clear all handlers if called without parameters + if (not @_) { + for (qw(Start End Char Final Init Comment Doctype XMLDecl)) { + *$_ = sub {} + } + } + + # we could use each here, too... + while (@_) { + my($name, $func) = splice(@_, 0, 2); + *$name = defined $func + ? $func + : sub {} + } + return $self; +} + +sub _regexp { + my $patch = shift || ''; + my $package = __PACKAGE__; + + # This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html + + # Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions", + # Technical Report TR 1998-17, School of Computing Science, Simon Fraser University, November, 1998. + # Copyright (c) 1998, Robert D. Cameron. + # The following code may be freely used and distributed provided that + # this copyright and citation notice remains intact and that modifications + # or additions are clearly identified. + + # Modifications may be tracked on SOAP::Lite's SVN at + # https://soaplite.svn.sourceforge.net/svnroot/soaplite/ + # + use re 'eval'; + my $TextSE = "[^<]+"; + my $UntilHyphen = "[^-]*-"; + my $Until2Hyphens = "([^-]*)-(?:[^-]$[^-]*-)*-"; + my $CommentCE = "$Until2Hyphens(?{${package}::comment(\$2)})>?"; +# my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-"; +# my $CommentCE = "$Until2Hyphens>?"; + my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+"; + my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>"; + my $S = "[ \\n\\t\\r]+"; + my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]"; + my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]"; + my $Name = "(?:$NameStrt)(?:$NameChar)*"; + my $QuoteSE = "\"[^\"]*\"|'[^']*'"; + my $DT_IdentSE = "$Name(?:$S(?:$Name|$QuoteSE))*"; +# my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*"; + my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>"; + my $S1 = "[\\n\\r\\t ]"; + my $UntilQMs = "[^?]*\\?"; + my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*"; + my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail>))|%$Name;|$S"; + my $DocTypeCE = "$S($DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?)>(?{${package}::_doctype(\$3)})"; +# my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>"; +# my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S"; +# my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?"; + my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?"; +# my $PI_CE = "$Name(?:$PI_Tail)?"; + my $PI_CE = "($Name(?:$PI_Tail))>(?{${package}::_xmldecl(\$5)})"; + # these expressions were modified for backtracking and events +# my $EndTagCE = "($Name)(?{${package}::_end(\$2)})(?:$S)?>"; + my $EndTagCE = "($Name)(?{${package}::_end(\$6)})(?:$S)?>"; + my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'"; +# my $ElemTagCE = "($Name)(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)(?{[\@{\$^R||[]},\$4=>defined\$5?\$5:\$6]}))*(?:$S)?(/)?>(?{${package}::_start( \$3,\@{\$^R||[]})})(?{\${7} and ${package}::_end(\$3)})"; + my $ElemTagCE = "($Name)" + . "(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)" + . "(?{[\@{\$^R||[]},\$8=>defined\$9?\$9:\$10]}))*(?:$S)?(/)?>" + . "(?{${package}::_start(\$7,\@{\$^R||[]})})(?{\$11 and ${package}::_end(\$7)})"; + + my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)"; + + # Next expression is under "black magic". + # Ideally it should be '($TextSE)(?{${package}::char(\$1)})|$MarkupSPE', + # but it doesn't work under Perl 5.005 and only magic with + # (?:....)?? solved the problem. + # I would appreciate if someone let me know what is the right thing to do + # and what's the reason for all this magic. + # Seems like a problem related to (?:....)? rather than to ?{} feature. + # Tests are in t/31-xmlparserlite.t if you decide to play with it. + #"(?{[]})(?:($TextSE)(?{${package}::_char(\$1)}))$patch|$MarkupSPE"; + "(?:($TextSE)(?{${package}::_char(\$1)}))$patch|$MarkupSPE"; } setHandlers(); -compile(); - -sub parse { - init(); - parse_re($_[1]); - final(); + +# Try 5.6 and 5.10 regex first +my $REGEXP = _regexp('??'); + +sub _parse_re { + use re "eval"; + undef $^R; + 1 while $_[0] =~ m{$REGEXP}go +}; + +# fixup regex if it does not work... +{ + if (not eval { _parse_re('bar'); 1; } ) { + $REGEXP = _regexp(); + local $^W; + *_parse_re = sub { + use re "eval"; + undef $^R; + 1 while $_[0] =~ m{$REGEXP}go + }; + } +} + +sub parse { + _init(); + _parse_re($_[1]); + _final(); } my(@stack, $level); -sub init { - @stack = (); $level = 0; - Init(__PACKAGE__, @_); -} - -sub final { - die "not properly closed tag '$stack[-1]'\n" if @stack; - die "no element found\n" unless $level; - Final(__PACKAGE__, @_) -} - -sub start { - die "multiple roots, wrong element '$_[0]'\n" if $level++ && !@stack; - push(@stack, $_[0]); - Start(__PACKAGE__, @_); -} - -sub char { - Char(__PACKAGE__, $_[0]), return if @stack; - - # check for junk before or after element - # can't use split or regexp due to limitations in ?{} implementation, - # will iterate with loop, but we'll do it no more than two times, so - # it shouldn't affect performance - for (my $i=0; $i < length $_[0]; $i++) { - die "junk '$_[0]' @{[$level ? 'after' : 'before']} XML element\n" - if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there - } -} - -sub end { - pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n"; - End(__PACKAGE__, $_[0]); -} +sub _init { + @stack = (); + $level = 0; + Init(__PACKAGE__, @_); +} + +sub _final { + die "not properly closed tag '$stack[-1]'\n" if @stack; + die "no element found\n" unless $level; + Final(__PACKAGE__, @_) +} + +sub _start { + die "multiple roots, wrong element '$_[0]'\n" if $level++ && !@stack; + push(@stack, $_[0]); + Start(__PACKAGE__, @_); +} + +sub _char { + Char(__PACKAGE__, $_[0]), return if @stack; + + # check for junk before or after element + # can't use split or regexp due to limitations in ?{} implementation, + # will iterate with loop, but we'll do it no more than two times, so + # it shouldn't affect performance + for (my $i=0; $i < length $_[0]; $i++) { + die "junk '$_[0]' @{[$level ? 'after' : 'before']} XML element\n" + if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there + } +} + +sub _end { + pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n"; + End(__PACKAGE__, $_[0]); +} + +sub comment { + Comment(__PACKAGE__, $_[0]); +} + +sub end { + pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n"; + End(__PACKAGE__, $_[0]); + } + +sub _doctype { + Doctype(__PACKAGE__, $_[0]); +} + +sub _xmldecl { + XMLDecl(__PACKAGE__, $_[0]); +} + + # ====================================================================== - 1; @@ -157,5 +218,5 @@ use XML::Parser::Lite; - + $p1 = new XML::Parser::Lite; $p1->setHandlers( @@ -177,10 +238,99 @@ =head1 DESCRIPTION -This Perl module gives you access to XML parser with interface similar to -XML::Parser interface. Though only basic calls are supported (init, final, -start, char, and end) you should be able to use it in the same way you use -XML::Parser. Due to using experimantal regexp features it'll work only on -Perl 5.6 and may behave differently on different platforms. - +This Perl implements an XML parser with a interface similar to +XML::Parser. Though not all callbacks are supported, you should be able to +use it in the same way you use XML::Parser. Due to using experimantal regexp +features it'll work only on Perl 5.6 and above and may behave differently on +different platforms. + +Note that you cannot use regular expressions or split in callbacks. This is +due to a limitation of perl's regular expression implementation (which is +not re-entrant). + +=head1 SUBROUTINES/METHODS + +=head2 new + +Constructor. + +As (almost) all SOAP::Lite constructors, new() returns the object called on +when called as object method. This means that the following effectifely is +a no-op if $obj is a object: + + $obj = $obj->new(); + +New accepts a single named parameter, C with a hash ref as value: + + my $parser = XML::Parser::Lite->new( + Handlers => { + Start => sub { shift; print "start: @_\n" }, + Char => sub { shift; print "char: @_\n" }, + End => sub { shift; print "end: @_\n" }, + } + ); + +The handlers given will be passed to setHandlers. + +=head2 setHandlers + +Sets (or resets) the parsing handlers. Accepts a hash with the handler names +and handler code references as parameters. Passing C instead of a +code reference replaces the handler by a no-op. + +The following handlers can be set: + + Init + Start + Char + End + Final + +All other handlers are ignored. + +Calling setHandlers without parameters resets all handlers to no-ops. + +=head2 parse + +Parses the XML given. In contrast to L's parse +method, parse() only parses strings. + +=head1 Handler methods + +=head2 Init + +Called before parsing starts. You should perform any necessary initializations +in Init. + +=head2 Start + +Called at the start of each XML node. See L for details. + +=head2 Char + +Called for each character sequence. May be called multiple times for the +characters contained in an XML node (even for every single character). +Your implementation has to make sure that it captures all characters. + +=head2 End + +Called at the end of each XML node. See L for details + +=head2 Comment + +See L for details + +=head2 XMLDecl + +See L for details + +=head2 Doctype + +See L for details + +=head2 Final + +Called at the end of the parsing process. You should perform any neccessary +cleanup here. + =head1 SEE ALSO @@ -189,5 +339,7 @@ =head1 COPYRIGHT -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. +Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved. + +Copyright (C) 2008- Martin Kutter. All rights reserved. This library is free software; you can redistribute it and/or modify @@ -201,3 +353,11 @@ Paul Kulchenko (paulclinger@yahoo.com) +Martin Kutter (martin.kutter@fen-net.de) + +Additional handlers supplied by Adam Leggett. + =cut + + + + Index: /trunk/extlib/XMLRPC/Lite.pm =================================================================== --- /trunk/extlib/XMLRPC/Lite.pm (revision 1098) +++ /trunk/extlib/XMLRPC/Lite.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: Lite.pm,v 1.10 2001/10/14 18:11:27 paulk Exp $ +# $Id: Lite.pm 254 2008-06-05 18:43:57Z kutterma $ # # ====================================================================== @@ -14,5 +14,5 @@ use strict; use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +use version; $VERSION = qv('0.710.06'); # ====================================================================== @@ -21,15 +21,15 @@ BEGIN { - no strict 'refs'; - for (qw( - FAULT_CLIENT FAULT_SERVER - HTTP_ON_SUCCESS_CODE HTTP_ON_FAULT_CODE - DO_NOT_USE_XML_PARSER DO_NOT_USE_CHARSET - DO_NOT_USE_LWP_LENGTH_HACK DO_NOT_CHECK_CONTENT_TYPE - )) { - *$_ = \${'SOAP::Constants::' . $_} - } - # XML-RPC spec requires content-type to be "text/xml" - $XMLRPC::Constants::DO_NOT_USE_CHARSET = 1; + no strict 'refs'; + for (qw( + FAULT_CLIENT FAULT_SERVER + HTTP_ON_SUCCESS_CODE HTTP_ON_FAULT_CODE + DO_NOT_USE_XML_PARSER DO_NOT_USE_CHARSET + DO_NOT_USE_LWP_LENGTH_HACK DO_NOT_CHECK_CONTENT_TYPE + )) { + *$_ = \${'SOAP::Constants::' . $_} + } + # XML-RPC spec requires content-type to be "text/xml" + $XMLRPC::Constants::DO_NOT_USE_CHARSET = 1; } @@ -47,149 +47,160 @@ sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new( - typelookup => { - base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'], - int => [20, sub {$_[0] =~ /^[+-]?\d+$/}, 'as_int'], - double => [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_double'], - dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'], - string => [40, sub {1}, 'as_string'], - }, - attr => {}, - namespaces => {}, - @_, - ); - } - return $self; + my $class = shift; + + return $class if ref $class; + + return $class->SUPER::new( + typelookup => { + base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'], + int => [20, sub {$_[0] =~ /^[+-]?\d+$/}, 'as_int'], + double => [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_double'], + dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'], + string => [40, sub {1}, 'as_string'], + }, + attr => {}, + namespaces => {}, + @_, + ); } sub envelope { - my $self = shift->new; - my $type = shift; - - my($body); - if ($type eq 'method' || $type eq 'response') { - my $method = shift or die "Unspecified method for XMLRPC call\n"; + my $self = shift; + $self = $self->new() if not ref $self; # serves a method call if object + my $type = shift; + + my $body; if ($type eq 'response') { - $body = XMLRPC::Data->name(methodResponse => \XMLRPC::Data->value( - XMLRPC::Data->type(params => [@_]) - )); - } else { - $body = XMLRPC::Data->name(methodCall => \XMLRPC::Data->value( - XMLRPC::Data->type(methodName => UNIVERSAL::isa($method => 'XMLRPC::Data') ? $method->name : $method), - XMLRPC::Data->type(params => [@_]) - )); - } - } elsif ($type eq 'fault') { - $body = XMLRPC::Data->name(methodResponse => - \XMLRPC::Data->type(fault => {faultCode => $_[0], faultString => $_[1]}), - ); - } else { - die "Wrong type of envelope ($type) for XMLRPC call\n"; - } - - $self->xmlize($self->encode_object($body)); -} - -sub encode_object { - my $self = shift; - my @encoded = $self->SUPER::encode_object(@_); - return $encoded[0]->[0] =~ /^(?:array|struct|i4|int|boolean|string|double|dateTime\.iso8601|base64)$/o - ? ['value', {}, [@encoded]] : @encoded; + # shift off method name to make XMLRPT happy + my $method = shift + or die "Unspecified method for XMLRPC call\n"; + $body = XMLRPC::Data->name( methodResponse => \XMLRPC::Data->value( + XMLRPC::Data->type(params => [@_]) + ) + ); + } + elsif ($type eq 'method') { + # shift off method name to make XMLRPT happy + my $method = shift + or die "Unspecified method for XMLRPC call\n"; + $body = XMLRPC::Data->name( methodCall => \XMLRPC::Data->value( + XMLRPC::Data->type( + methodName => UNIVERSAL::isa($method => 'XMLRPC::Data') + ? $method->name + : $method + ), + XMLRPC::Data->type(params => [@_]) + )); + } + elsif ($type eq 'fault') { + $body = XMLRPC::Data->name(methodResponse => + \XMLRPC::Data->type(fault => {faultCode => $_[0], faultString => $_[1]}), + ); + } + else { + die "Wrong type of envelope ($type) for XMLRPC call\n"; + } + + # SOAP::Lite keeps track of objects for XML aliasing and multiref + # encoding. + # Set/reset seen() hashref before/after encode_object avoids a + # memory leak + $self->seen({}); # initialize multiref table + my $envelope = $self->xmlize($self->encode_object($body)); + $self->seen({}); # delete multi-ref table - avoids a memory hole... + return $envelope; +} + + +sub encode_object { + my $self = shift; + my @encoded = $self->SUPER::encode_object(@_); + + return $encoded[0]->[0] =~ /^(?:array|struct|i4|int|boolean|string|double|dateTime\.iso8601|base64)$/o + ? ['value', {}, [@encoded]] + : @encoded; } sub encode_scalar { - my $self = shift; - return ['value', {}] unless defined $_[0]; - return $self->SUPER::encode_scalar(@_); + my $self = shift; + return ['value', {}] unless defined $_[0]; + return $self->SUPER::encode_scalar(@_); } sub encode_array { - my($self, $array) = @_; - - return ['array', {}, [ - ['data', {}, [map {$self->encode_object($_)} @$array]] - ]]; + my ($self, $array) = @_; + + return ['array', {}, [ + ['data', {}, [ map {$self->encode_object($_)} @{ $array } ] ] + ]]; } sub encode_hash { - my($self, $hash) = @_; - - return ['struct', {}, [ - map { - ['member', {}, [['name', {}, $_], $self->encode_object($hash->{$_})]] - } keys %$hash - ]]; + my ($self, $hash) = @_; + + return ['struct', {}, [ + map { + ['member', {}, [['name', {}, $_], $self->encode_object($hash->{$_})]] + } keys %{ $hash } + ]]; } sub as_methodName { - my $self = shift; - my($value, $name, $type, $attr) = @_; - return ['methodName', $attr, $value]; + my ($self, $value, $name, $type, $attr) = @_; + return [ 'methodName', $attr, $value ]; } sub as_params { - my $self = shift; - my($params, $name, $type, $attr) = @_; - - return ['params', $attr, [ - map { - ['param', {}, [$self->encode_object($_)]] - } @$params - ]]; + my ($self, $params, $name, $type, $attr) = @_; + return ['params', $attr, [ + map { + ['param', {}, [ $self->encode_object($_) ] ] + } @$params + ]]; } sub as_fault { - my($self, $fault) = @_; - - return ['fault', {}, [$self->encode_object($fault)]]; + my ($self, $fault) = @_; + return ['fault', {}, [ $self->encode_object($fault) ] ]; } sub BEGIN { - no strict 'refs'; - for my $type (qw(double i4 int)) { - my $method = 'as_' . $type; - *$method = sub { - my($self, $value) = @_; - return [$type, {}, $value]; - } - } + no strict 'refs'; + for my $type (qw(double i4 int)) { + my $method = 'as_' . $type; + *$method = sub { + my($self, $value) = @_; + return [ $type, {}, $value ]; + } + } } sub as_base64 { - my $self = shift; - my $value = shift; - require MIME::Base64; - return ['base64', {}, MIME::Base64::encode_base64($value,'')]; + my ($self, $value) = @_; + require MIME::Base64; + return ['base64', {}, MIME::Base64::encode_base64($value,'')]; } sub as_string { - my $self = shift; - my $value = shift; - return ['string', {}, SOAP::Utils::encode_data($value)]; + my ($self, $value) = @_; + return ['string', {}, SOAP::Utils::encode_data($value)]; } sub as_dateTime { - my $self = shift; - my $value = shift; - return ['dateTime.iso8601', {}, $value]; + my ($self, $value) = @_; + return ['dateTime.iso8601', {}, $value]; } sub as_boolean { - my $self = shift; - my $value = shift; - return ['boolean', {}, $value ? 1 : 0]; + my ($self, $value) = @_; + return ['boolean', {}, $value ? 1 : 0]; } sub typecast { - my $self = shift; - my($value, $name, $type, $attr) = @_; - - die "Wrong/unsupported datatype '$type' specified\n" if defined $type; - - $self->SUPER::typecast(@_); + my ($self, $value, $name, $type, $attr) = @_; + + die "Wrong/unsupported datatype '$type' specified\n" if defined $type; + + $self->SUPER::typecast(@_); } @@ -201,44 +212,51 @@ sub BEGIN { - no strict 'refs'; - my %path = ( - root => '/', - envelope => '/[1]', - method => '/methodCall/methodName', - fault => '/methodResponse/fault', - ); - for my $method (keys %path) { - *$method = sub { - my $self = shift; - ref $self or return $path{$method}; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - $self->valueof($path{$method}); - }; - } - my %fault = ( - faultcode => 'faultCode', - faultstring => 'faultString', - ); - for my $method (keys %fault) { - *$method = sub { - my $self = shift; - ref $self or Carp::croak "Method '$method' doesn't have shortcut"; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - defined $self->fault ? $self->fault->{$fault{$method}} : undef; - }; - } - my %results = ( - result => '/methodResponse/params/[1]', - paramsin => '/methodCall/params/param', - paramsall => '/methodResponse/params/param', - ); - for my $method (keys %results) { - *$method = sub { - my $self = shift; - ref $self or return $results{$method}; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - defined $self->fault ? undef : $self->valueof($results{$method}); - }; - } + no strict 'refs'; + my %path = ( + root => '/', + envelope => '/[1]', + method => '/methodCall/methodName', + fault => '/methodResponse/fault', + ); + + for my $method (keys %path) { + *$method = sub { + my $self = shift; + ref $self or return $path{$method}; + Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; + $self->valueof($path{$method}); + }; + } + + my %fault = ( + faultcode => 'faultCode', + faultstring => 'faultString', + ); + + for my $method (keys %fault) { + *$method = sub { + my $self = shift; + ref $self or Carp::croak "Method '$method' doesn't have shortcut"; + Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; + defined $self->fault ? $self->fault->{$fault{$method}} : undef; + }; + } + + my %results = ( + result => '/methodResponse/params/[1]', + paramsin => '/methodCall/params/param', + paramsall => '/methodResponse/params/param', + ); + + for my $method (keys %results) { + *$method = sub { + my $self = shift; + ref $self or return $results{$method}; + Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; + defined $self->fault() + ? undef + : $self->valueof($results{$method}); + }; + } } @@ -250,43 +268,54 @@ BEGIN { - no strict 'refs'; - for my $method (qw(o_child o_qname o_chars)) { # import from SOAP::Utils - *$method = \&{'SOAP::Utils::'.$method}; - } + no strict 'refs'; + for my $method (qw(o_child o_qname o_chars)) { # import from SOAP::Utils + *$method = \&{'SOAP::Utils::'.$method}; + } } sub deserialize { - bless shift->SUPER::deserialize(@_) => 'XMLRPC::SOM'; + # just deserialize with SOAP::Lite's deserializer, and re-bless as + # XMLRPC::SOM + bless shift->SUPER::deserialize(@_) => 'XMLRPC::SOM'; } sub decode_value { - my $self = shift; - my $ref = shift; - my($name, $attrs, $children, $value) = @$ref; - - if ($name eq 'value') { - $children ? scalar(($self->decode_object($children->[0]))[1]) : $value; - } elsif ($name eq 'array') { - return [map {scalar(($self->decode_object($_))[1])} @{o_child($children->[0]) || []}]; - } elsif ($name eq 'struct') { - return {map { - my %hash = map {o_qname($_) => $_} @{o_child($_) || []}; - # v----- scalar is required here, because 5.005 evaluates 'undef' in list context as empty array - (o_chars($hash{name}) => scalar(($self->decode_object($hash{value}))[1])); - } @{$children || []}}; - } elsif ($name eq 'base64') { - require MIME::Base64; - MIME::Base64::decode_base64($value); - } elsif ($name =~ /^(?:int|i4|boolean|string|double|dateTime\.iso8601|methodName)$/) { - return $value; - } elsif ($name =~ /^(?:params)$/) { - return [map {scalar(($self->decode_object($_))[1])} @{$children || []}]; - } elsif ($name =~ /^(?:methodResponse|methodCall)$/) { - return +{map {$self->decode_object($_)} @{$children || []}}; - } elsif ($name =~ /^(?:param|fault)$/) { - return scalar(($self->decode_object($children->[0]))[1]); - } else { - die "wrong element '$name'\n"; - } + my $self = shift; + my $ref = shift; + my($name, $attrs, $children, $value) = @$ref; + + if ($name eq 'value') { + $children ? scalar(($self->decode_object($children->[0]))[1]) : $value; + } + elsif ($name eq 'array') { + return [map {scalar(($self->decode_object($_))[1])} @{o_child($children->[0]) || []}]; + } + elsif ($name eq 'struct') { + return { + map { + my %hash = map { o_qname($_) => $_ } @{o_child($_) || []}; + # v----- scalar is required here, because 5.005 evaluates 'undef' in list context as empty array + (o_chars($hash{name}) => scalar(($self->decode_object($hash{value}))[1])); + } @{$children || []}}; + } + elsif ($name eq 'base64') { + require MIME::Base64; + MIME::Base64::decode_base64($value); + } + elsif ($name =~ /^(?:int|i4|boolean|string|double|dateTime\.iso8601|methodName)$/) { + return $value; + } + elsif ($name =~ /^(?:params)$/) { + return [map {scalar(($self->decode_object($_))[1])} @{$children || []}]; + } + elsif ($name =~ /^(?:methodResponse|methodCall)$/) { + return +{map {$self->decode_object($_)} @{$children || []}}; + } + elsif ($name =~ /^(?:param|fault)$/) { + return scalar(($self->decode_object($children->[0]))[1]); + } + else { + die "wrong element '$name'\n"; + } } @@ -298,10 +327,10 @@ sub initialize { - return ( - deserializer => XMLRPC::Deserializer->new, - serializer => XMLRPC::Serializer->new, - on_action => sub {}, - on_dispatch => sub { return map {s!\.!/!g; $_} shift->method =~ /^(?:(.*)\.)?(\w+)$/ }, - ); + return ( + deserializer => XMLRPC::Deserializer->new, + serializer => XMLRPC::Serializer->new, + on_action => sub {}, + on_dispatch => sub { return map {s!\.!/!g; $_} shift->method =~ /^(?:(.*)\.)?(\w+)$/ }, + ); } @@ -325,17 +354,15 @@ sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new( - serializer => XMLRPC::Serializer->new, - deserializer => XMLRPC::Deserializer->new, - on_action => sub {return}, - uri => 'http://unspecified/', - @_ - ); - } - return $self; + my $class = shift; + + return $class if ref $class; + + return $class->SUPER::new( + serializer => XMLRPC::Serializer->new, + deserializer => XMLRPC::Deserializer->new, + on_action => sub {return}, + uri => 'http://unspecified/', + @_ + ); } @@ -348,5 +375,5 @@ =head1 NAME -XMLRPC::Lite - client and server implementation of XML-RPC protocol +XMLRPC::Lite - client and server implementation of XML-RPC protocol =head1 SYNOPSIS @@ -390,5 +417,5 @@ it gives you access to all features and transports available in that module. -See F for client examples and F for server +See F for client examples and F for server implementations. @@ -404,5 +431,5 @@ The B standard is Copyright (c) 1998-2001, UserLand Software, Inc. -See for more information about the B +See for more information about the B specification. Index: /trunk/extlib/XMLRPC/Test.pm =================================================================== --- /trunk/extlib/XMLRPC/Test.pm (revision 1098) +++ /trunk/extlib/XMLRPC/Test.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: Test.pm,v 1.4 2001/09/19 18:07:54 paulk Exp $ +# $Id: Test.pm 249 2008-05-05 20:35:05Z kutterma $ # # ====================================================================== @@ -13,5 +13,5 @@ use 5.004; use vars qw($VERSION $TIMEOUT); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +use version; $VERSION = qv('0.710.05'); $TIMEOUT = 5; @@ -21,5 +21,5 @@ package My::PingPong; # we'll use this package in our tests -sub new { +sub new { my $self = shift; my $class = ref($self) || $self; @@ -69,12 +69,12 @@ ; - ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); - ok($s->call('My.Examples.getStateNames', 1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/); + ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); + ok($s->call('My.Examples.getStateNames', 1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/); $r = $s->call('My.Examples.getStateList', [1,2,3,4])->result; - ok(ref $r && $r->[0] eq 'Alabama'); + ok(ref $r && $r->[0] eq 'Alabama'); $r = $s->call('My.Examples.getStateStruct', {item1 => 1, item2 => 4})->result; - ok(ref $r && $r->{item2} eq 'Arkansas'); + ok(ref $r && $r->{item2} eq 'Arkansas'); print "dispatch_from test(s)...\n"; @@ -95,5 +95,5 @@ # forget everything - XMLRPC::Lite->self(undef); + XMLRPC::Lite->self(undef); { @@ -124,10 +124,10 @@ print "Memory refresh test(s)...\n"; - # Funny test. + # Funny test. # Let's forget about ALL settings we did before with 'use XMLRPC::Lite...' - XMLRPC::Lite->self(undef); + XMLRPC::Lite->self(undef); ok(!defined XMLRPC::Lite->self); - eval "use XMLRPC::Lite + eval "use XMLRPC::Lite proxy => '$proxy'; 1" or die; @@ -137,5 +137,5 @@ ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); - SOAP::Trace->import(transport => + SOAP::Trace->import(transport => sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')} ); Index: /trunk/extlib/XMLRPC/Transport/TCP.pm =================================================================== --- /trunk/extlib/XMLRPC/Transport/TCP.pm (revision 1098) +++ /trunk/extlib/XMLRPC/Transport/TCP.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: TCP.pm,v 1.3 2001/08/11 19:09:58 paulk Exp $ +# $Id: TCP.pm 51 2004-11-14 19:30:50Z byrnereese $ # # ====================================================================== @@ -13,5 +13,6 @@ use strict; use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); +$VERSION = $XMLPRC::Lite::VERSION; use XMLRPC::Lite; Index: /trunk/extlib/XMLRPC/Transport/HTTP.pm =================================================================== --- /trunk/extlib/XMLRPC/Transport/HTTP.pm (revision 1098) +++ /trunk/extlib/XMLRPC/Transport/HTTP.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: HTTP.pm,v 1.5 2001/10/14 18:11:27 paulk Exp $ +# $Id: HTTP.pm 51 2004-11-14 19:30:50Z byrnereese $ # # ====================================================================== @@ -13,5 +13,6 @@ use strict; use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); +$VERSION = $XMLRPC::Lite::VERSION; use XMLRPC::Lite; Index: /trunk/extlib/XMLRPC/Transport/POP3.pm =================================================================== --- /trunk/extlib/XMLRPC/Transport/POP3.pm (revision 1098) +++ /trunk/extlib/XMLRPC/Transport/POP3.pm (revision 3531) @@ -5,5 +5,5 @@ # and/or modify it under the same terms as Perl itself. # -# $Id: POP3.pm,v 1.3 2001/08/11 19:09:58 paulk Exp $ +# $Id: POP3.pm 51 2004-11-14 19:30:50Z byrnereese $ # # ====================================================================== @@ -13,5 +13,6 @@ use strict; use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: release-0_52-public $ =~ /-(\d+)_([\d_]+)/); +#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/); +$VERSION = $XMLRPC::Lite::VERSION; use XMLRPC::Lite; Index: /trunk/extlib/JSON/PP/Boolean.pm =================================================================== --- /trunk/extlib/JSON/PP/Boolean.pm (revision 3531) +++ /trunk/extlib/JSON/PP/Boolean.pm (revision 3531) @@ -0,0 +1,26 @@ +=head1 NAME + +JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + +=head1 SYNOPSIS + + # do not "use" yourself + +=head1 DESCRIPTION + +This module exists only to provide overload resolution for Storable and similar modules. See +L for more info about this class. + +=cut + +use JSON::PP (); +use strict; + +1; + +=head1 AUTHOR + +This idea is from L written by Marc Lehmann + +=cut + Index: /trunk/extlib/JSON/PP5005.pm =================================================================== --- /trunk/extlib/JSON/PP5005.pm (revision 3531) +++ /trunk/extlib/JSON/PP5005.pm (revision 3531) @@ -0,0 +1,177 @@ +package JSON::PP5005; + +use 5.005; +use strict; + +my @properties; + +$JSON::PP5005::VERSION = '1.07'; + +BEGIN { + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + + + sub utf8::is_utf8 { + 0; # It is considered that UTF8 flag off for Perl 5.005. + } + + sub utf8::upgrade { + } + + sub utf8::downgrade { + 1; # must always return true. + } + + sub utf8::encode { + } + + sub utf8::decode { + } + + # missing in B module. + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + sub B::SVf_POK () { 0x00040000; } + sub B::SVp_IOK () { 0x01000000; } + sub B::SVp_NOK () { 0x02000000; } + + $INC{'bytes.pm'} = 1; # dummy +} + + + +sub _encode_ascii { + join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) ); +} + + +sub _encode_latin1 { + join('', map { chr($_) } unpack('C*', $_[0]) ); +} + + +sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode + my $bit = unpack('B32', pack('N', $uni)); + + if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) { + my ($w, $x, $y, $z) = ($1, $2, $3, $4); + return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z)); + } + else { + Carp::croak("Invalid surrogate pair"); + } +} + + +sub _decode_unicode { + my ($u) = @_; + my ($utf8bit); + my $bit = unpack("B*", pack("H*", $u)); + + if ( $bit =~ /^00000(.....)(......)$/ ) { + $utf8bit = sprintf('110%s10%s', $1, $2); + } + elsif ( $bit =~ /^(....)(......)(......)$/ ) { + $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3); + } + else { + Carp::croak("Invalid escaped unicode"); + } + + return pack('B*', $utf8bit); +} + + +sub _is_valid_utf8 { + my $str = $_[0]; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + if ($is_utf8) { # eventually, not utf8 + return; + } + } + } + + return $is_utf8; +} + + +sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub JSON::PP::incr_text { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + + $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 ); + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; +} + + +sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + Index: /trunk/extlib/JSON/PP56.pm =================================================================== --- /trunk/extlib/JSON/PP56.pm (revision 3531) +++ /trunk/extlib/JSON/PP56.pm (revision 3531) @@ -0,0 +1,197 @@ +package JSON::PP56; + +use 5.006; +use strict; + +my @properties; + +$JSON::PP56::VERSION = '1.06'; + +BEGIN { + sub utf8::is_utf8 { + my $len = length $_[0]; # char length + { + use bytes; # byte length; + return $len != length $_[0]; # if !=, UTF8-flagged on. + } + } + + + sub utf8::upgrade { + ; # noop; + } + + + sub utf8::downgrade (\$;$) { + return 1 unless ( utf8::is_utf8( ${$_[0]} ) ); + + if ( _is_valid_utf8(${$_[0]}) ) { + my $downgrade; + for my $c ( unpack("U*", ${$_[0]}) ) { + if ( $c < 256 ) { + $downgrade .= pack("C", $c); + } + else { + $downgrade .= pack("U", $c); + } + } + ${$_[0]} = $downgrade; + return 1; + } + else { + Carp::croak("Wide character in subroutine entry") unless ( $_[1] ); + 0; + } + } + + + sub utf8::encode (\$) { # UTF8 flag off + if ( utf8::is_utf8( ${$_[0]} ) ) { + ${$_[0]} = pack( "C*", unpack( "C*", ${$_[0]} ) ); + } + else { + ${$_[0]} = pack( "U*", map { + if ( $_ > 127 ) { + unpack ( "C*", pack("U*", $_) ); + } + else { + $_; + } + } unpack( "C*", ${$_[0]} ) ); + } + } + + + sub utf8::decode (\$) { # UTF8 flag on + if ( _is_valid_utf8(${$_[0]}) ) { + ${$_[0]} = pack("U*", unpack("U*", ${$_[0]})); + } + } + + + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode; +} + + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); +} + + +sub _unpack_emu { # for Perl 5.6 unpack warnings + return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) + : _is_valid_utf8($_[0]) ? unpack('U*', $_[0]) + : unpack('C*', $_[0]); +} + + +sub _is_valid_utf8 { + my $str = $_[0]; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + if ($is_utf8) { # eventually, not utf8 + return; + } + } + } + + return $is_utf8; +} + + +sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; +} + + +sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + Index: /trunk/extlib/JSON/PP58.pm =================================================================== --- /trunk/extlib/JSON/PP58.pm (revision 3531) +++ /trunk/extlib/JSON/PP58.pm (revision 3531) @@ -0,0 +1,93 @@ +package JSON::PP58; + +use 5.008; +use strict; + +my @properties; + +$JSON::PP58::VERSION = '1.02'; + + +BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + *JSON::PP::JSON_PP_encode_ascii = \&JSON::PP::_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&JSON::PP::_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode; + + if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + +} + + +sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); +} + + +sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; +} + + +sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; +} + + +sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; +} + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP58 - Helper module in using JSON::PP in Perl 5.8 and lator + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + Index: /trunk/extlib/JSON/PP.pm =================================================================== --- /trunk/extlib/JSON/PP.pm (revision 3531) +++ /trunk/extlib/JSON/PP.pm (revision 3531) @@ -0,0 +1,2119 @@ +package JSON::PP; + +# JSON-2.0 + +use 5.005; +use strict; +use base qw(Exporter); +use overload; + +use Carp (); +use B (); +#use Devel::Peek; + +$JSON::PP::VERSION = '2.22000'; + +@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + +# instead of hash-access, i tried index-access for speed. +# but this method is not faster than what i expected. so it will be changed. + +use constant P_ASCII => 0; +use constant P_LATIN1 => 1; +use constant P_UTF8 => 2; +use constant P_INDENT => 3; +use constant P_CANONICAL => 4; +use constant P_SPACE_BEFORE => 5; +use constant P_SPACE_AFTER => 6; +use constant P_ALLOW_NONREF => 7; +use constant P_SHRINK => 8; +use constant P_ALLOW_BLESSED => 9; +use constant P_CONVERT_BLESSED => 10; +use constant P_RELAXED => 11; + +use constant P_LOOSE => 12; +use constant P_ALLOW_BIGNUM => 13; +use constant P_ALLOW_BAREKEY => 14; +use constant P_ALLOW_SINGLEQUOTE => 15; +use constant P_ESCAPE_SLASH => 16; +use constant P_AS_NONBLESSED => 17; + +use constant P_ALLOW_UNKNOWN => 18; + +BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enable? + # Helper module sets @JSON::PP::_properties. + + my $helper = $] >= 5.008 ? 'JSON::PP58' + : $] >= 5.006 ? 'JSON::PP56' + : 'JSON::PP5005' + ; + + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $flag_name = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$flag_name] = 1; + } + else { + \$_[0]->{PROPS}->[$flag_name] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; + } + /; + } + +} + + + +# Functions + +my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash + allow_blessed convert_blessed indent indent_length allow_bignum + as_nonblessed + /; +my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum + allow_barekey max_size relaxed/; + + +my $JSON; # cache + +sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); +} + + +sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); +} + +# Obsoleted + +sub to_json($) { + Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); +} + + +sub from_json($) { + Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); +} + + +# Methods + +sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent => 0, + FLAGS => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + indent_length => 3, + }; + + bless $self, $class; +} + + +sub encode { + return $_[0]->PP_encode_json($_[1]); +} + + +sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); +} + + +sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); +} + + +# accessor + + +# pretty printing + +sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; +} + +# etc + +sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; +} + + +sub get_max_depth { $_[0]->{max_depth}; } + + +sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; +} + + +sub get_max_size { $_[0]->{max_size}; } + + +sub filter_json_object { + $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub filter_json_single_key_object { + if (@_ > 1) { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; +} + +sub get_indent_length { + $_[0]->{indent_length}; +} + +sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; +} + +sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); +} + +############################### + +### +### Perl => JSON +### + + +{ # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $idx = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed) + = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($idx->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and $obj eq $result ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. + + encode_error( sprintf("encountered object '%s', but neither allow_blessed " + . "nor convert_blessed settings are enabled", $obj) + ) unless ($allow_blessed); + + return 'null'; + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + if ( my $tie_class = tied %$obj ) { + if ( $tie_class->can('TIEHASH') ) { + $tie_class =~ s/=.+$//; + tie %res, $tie_class; + } + } + + # In the old Perl verions, tied hashes in bool context didn't work. + # So, we can't use such a way (%res ? a : b) + my $has; + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->object_to_json($v) || $self->value_to_json($v); + $has = 1 unless ( $has ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{' . ( $has ? $pre : '' ) # indent + . ( $has ? join(",$pre", map { utf8::decode($_) if ($] < 5.008); # key for Perl 5.6 + string_to_json($self, $_) . $del . $res{$_} # key : value + } _sort( $self, \%res ) + ) . $post # indent + : '' + ) + . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + if (my $tie_class = tied @$obj) { + if ( $tie_class->can('TIEARRAY') ) { + $tie_class =~ s/=.+$//; + tie @res, $tie_class; + } + } + + for my $v (@$obj){ + push @res, $self->object_to_json($v) || $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; + } + + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + my $flags = $b_obj->FLAGS; + + return $value # as is + if ( ( $flags & B::SVf_IOK or $flags & B::SVp_IOK + or $flags & B::SVf_NOK or $flags & B::SVp_NOK + ) and !($flags & B::SVf_POK ) + ); # SvTYPE is IV or NV? + + my $type = ref($value); + + if(!$type){ + return string_to_json($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $b_obj = B::svref_2object($_[1]); + if ($b_obj->isa('B::HV')) { + return $_[0]->hash_to_json($_[1]); + } + elsif ($b_obj->isa('B::AV')) { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + my ($self, $res) = @_; + defined $keysort ? (sort $keysort (keys %$res)) : keys %$res; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + +} # Convert + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); +} + + +sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); +} + + + +# +# JSON => Perl +# + +my $max_intsize; + +BEGIN { + my $checkint = 1111; + for my $d (5..30) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } +} + +{ # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $is_utf8; # must be with UTF8 flag + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest nubmer of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bigint; # using Math::BigInt + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + + sub PP_decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if (!defined $text or ref $text) { + decode_error("malformed text data."); + } + + my $idx = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) + = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; + + $is_utf8 = 1 if ( $utf8 or utf8::is_utf8( $text ) ); + + if ( $utf8 ) { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + else { + utf8::upgrade( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + # Currently no effect + # should use regexp + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + my $result = value(); + + if (!$idx->[ P_ALLOW_NONREF ] and !ref $result) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + if ($len >= $at) { + my $consumed = $at - 1; + white(); + if ($ch) { + decode_error("garbage after JSON object") unless ($opt & 0x00000001); + return ($result, $consumed); + } + } + + $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my ($i, $s, $t, $u); + my $utf16; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch if ($singlequote); + + OUTER: while( defined(next_chr()) ){ + + if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ((my $hex = hex( $u )) > 255) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + if ($utf8) { + if( !is_valid_utf8($ch) ) { + $at -= $utf8_len; + decode_error("malformed UTF-8 character in JSON string"); + } + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = []; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub object { + my $o = {}; + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at--; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + decode_error("malformed number (leading zero must not be followed by another digit)"); + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + if (defined $n and length $n > 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($v !~ /[.eE]/ and length $v > $max_intsize) { + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + elsif ($allow_bigint) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + + return 0+$v; + } + + + sub is_valid_utf8 { + unless ( $utf8_len ) { + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + } + + return !($utf8_len = 1) unless ( $utf8_len ); + + return 1 if (length ($is_valid_utf8 .= $_[0] ) < $utf8_len); # continued + + return ( $is_valid_utf8 =~ s/^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$//x and !($utf8_len = 0) ); # if valid, make $is_valid_utf8 empty and rest $utf8_len. + + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = $] >= 5.008 ? 'U*' + : $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at [\"$mess\"]" + ); + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 1) { + return $val[0]; + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0 or @val > 1) { + return $o; + } + else { + return $val[0]; + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + is_utf8 => $is_utf8, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + +} # PARSE + + +sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + return pack('U*', $uni); +} + + +sub _decode_unicode { + return pack("U", hex shift); +} + + + + + +############################### +# Utilities +# + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } +} + + +# shamely copied and modified from JSON::XS code. + +$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; +$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + +sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } + +sub true { $JSON::PP::true } +sub false { $JSON::PP::false } +sub null { undef; } + +############################### + +package JSON::PP::Boolean; + + +use overload ( + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, +); + + +############################### + +package JSON::PP::IncrParser; + +use strict; + +use constant INCR_M_WS => 0; # initial whitespace skipping +use constant INCR_M_STR => 1; # inside string +use constant INCR_M_BS => 2; # inside backslash +use constant INCR_M_JSON => 3; # outside anything, count nesting + +$JSON::PP::IncrParser::VERSION = '1.01'; + +my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; + +sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_parsing => 0, + incr_p => 0, + + }, $class; +} + + +sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + + my $max_size = $coder->get_max_size; + + if ( defined wantarray ) { + + $self->{incr_mode} = INCR_M_WS; + + if ( wantarray ) { + my @ret; + + $self->{incr_parsing} = 1; + + do { + push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); + + unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { + $self->{incr_mode} = INCR_M_WS; + } + + } until ( !$self->{incr_text} ); + + $self->{incr_parsing} = 0; + + return @ret; + } + else { # in scalar context + $self->{incr_parsing} = 1; + my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); + $self->{incr_parsing} = 0; + return $obj; + } + + } + +} + + +sub _incr_parse { + my ( $self, $coder, $text, $skip ) = @_; + my $p = $self->{incr_p}; + my $restore = $p; + + my @obj; + my $len = length $text; + + if ( $self->{incr_mode} == INCR_M_WS ) { + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); + $self->{incr_mode} = INCR_M_JSON; + last; + } + } + + while ( $len > $p ) { + my $s = substr( $text, $p++, 1 ); + + if ( $s eq '"' ) { + if ( $self->{incr_mode} != INCR_M_STR ) { + $self->{incr_mode} = INCR_M_STR; + } + else { + $self->{incr_mode} = INCR_M_JSON; + unless ( $self->{incr_nest} ) { + last; + } + } + } + + if ( $self->{incr_mode} == INCR_M_JSON ) { + + if ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + } + elsif ( $s eq ']' or $s eq '}' ) { + last if ( --$self->{incr_nest} <= 0 ); + } + } + + } + + $self->{incr_p} = $p; + + return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); + + return unless ( length substr( $self->{incr_text}, 0, $p ) ); + + local $Carp::CarpLevel = 2; + + $self->{incr_p} = $restore; + $self->{incr_c} = $p; + + my ( $obj, $tail ) = $coder->decode_prefix( substr( $self->{incr_text}, 0, $p ) ); + + $self->{incr_text} = substr( $self->{incr_text}, $p ); + $self->{incr_p} = 0; + + return $obj; +} + + +sub incr_text { + if ( $_[0]->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; +} + + +sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); + $self->{incr_p} = 0; +} + + +sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_p} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; + $self->{incr_parsing} = 0; +} + +############################### + + +1; +__END__ +=pod + +=head1 NAME + +JSON::PP - JSON::XS compatible pure-Perl module. + +=head1 SYNOPSIS + + use JSON::PP; + + # exported functions, they croak on error + # and expect/generate UTF-8 + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $coder = JSON::PP->new->ascii->pretty->allow_nonref; + $pretty_printed_unencoded = $coder->encode ($perl_scalar); + $perl_scalar = $coder->decode ($unicode_json_text); + + # Note that JSON version 2.0 and above will automatically use + # JSON::XS or JSON::PP, so you should be able to just: + + use JSON; + +=head1 DESCRIPTION + +This module is L compatible pure Perl module. +(Perl 5.8 or later is recommended) + +JSON::XS is the fastest and most proper JSON module on CPAN. +It is written by Marc Lehmann in C, so must be compiled and +installed in the used environment. + +JSON::PP is a pure-Perl module and has compatibility to JSON::XS. + + +=head2 FEATURES + +=over + +=item * correct unicode handling + +This module knows how to handle Unicode (depending on Perl version). + +See to L and L. + + +=item * round-trip integrity + +When you serialise a perl data structure using only datatypes supported by JSON, +the deserialised data structure is identical on the Perl level. +(e.g. the string "2.0" doesn't suddenly become "2" just because it looks like a number). + +=item * strict checking of JSON correctness + +There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default (the latter is a security feature). +But when some options are set, loose chcking features are available. + +=back + +=head1 FUNCTIONS + +Basically, check to L or L. + +=head2 encode_json + + $json_text = encode_json $perl_scalar + +=head2 decode_json + + $perl_scalar = decode_json $json_text + +=head2 JSON::PP::true + +Returns JSON true value which is blessed object. +It C JSON::PP::Boolean object. + +=head2 JSON::PP::false + +Returns JSON false value which is blessed object. +It C JSON::PP::Boolean object. + +=head2 JSON::PP::null + +Returns C. + +=head1 METHODS + +Basically, check to L or L. + +=head2 new + + $json = new JSON::PP + +Rturns a new JSON::PP object that can be used to de/encode JSON +strings. + +=head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + +If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. +(See to L). + +In Perl 5.005, there is no character having high value (more than 255). +See to L. + +If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format. + + JSON::PP->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + +=head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + +If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + +If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags. + + JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + +See to L. + +=head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + +If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + +(In Perl 5.005, any character outside the range 0..255 does not exist. +See to L.) + +In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627. + +If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + +Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); + +Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + + +=head2 pretty + + $json = $json->pretty([$enable]) + +This enables (or disables) all of the C, C and +C flags in one call to generate the most readable +(or most compact) form possible. + +=head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + +The default indent space lenght is three. +You can use C to change the length. + +=head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + +=head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + +=head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + +=head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + +If you want your own sorting routine, you can give a code referece +or a subroutine name to C. See to C. + +=head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + +=head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + +=head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + +=head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + +=head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + +=head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + +=head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + +In JSON::XS, this flag resizes strings generated by either +C or C to their minimum size possible. +It will also try to downgrade any strings to octet-form if possible. + +In JSON::PP, it is noop about resizing strings but tries +C to the returned string by C. +See to L. + +See to L + +=head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + +Sets the maximum nesting level (default C<512>) accepted while encoding +or decoding. If a higher nesting level is detected in JSON text or a Perl +data structure, then the encoder and decoder will stop and croak at that +point. + +Nesting level is defined by number of hash- or arrayrefs that the encoder +needs to traverse to reach a given point or the number of C<{> or C<[> +characters without their matching closing parenthesis crossed to reach a +given character in a string. + +If no argument is given, the highest possible setting will be used, which +is rarely useful. + +See L for more info on why this is useful. + +When a large value (100 or more) was set and it de/encodes a deep nested object/text, +it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. + +=head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + +Set the maximum length a JSON text may have (in bytes) where decoding is +being attempted. The default is C<0>, meaning no limit. When C +is called on a string that is longer then this many bytes, it will not +attempt to decode the string but throw an exception. This setting has no +effect on C (yet). + +If no argument is given, the limit check will be deactivated (same as when +C<0> is specified). + +See L for more info on why this is useful. + +=head2 encode + + $json_text = $json->encode($perl_scalar) + +=head2 decode + + $perl_scalar = $json->decode($json_text) + +=head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + + +=head1 INCREMENTAL PARSING + +In JSON::XS 2.2, incremental parsing feature of JSON +texts was experimentally implemented. +Please check to L. + +=over 4 + +=item [void, scalar or list context] = $json->incr_parse ([$string]) + +This is the central parsing function. It can both append new text and +extract objects from the stream accumulated so far (both of these +functions are optional). + +If C<$string> is given, then this string is appended to the already +existing JSON fragment stored in the C<$json> object. + +After that, if the function is called in void context, it will simply +return without doing anything further. This can be used to add more text +in as many chunks as you want. + +If the method is called in scalar context, then it will try to extract +exactly I JSON object. If that is successful, it will return this +object, otherwise it will return C. If there is a parse error, +this method will croak just as C would do (one can then use +C to skip the errornous part). This is the most common way of +using the method. + +And finally, in list context, it will try to extract as many objects +from the stream as it can find and return them, or the empty list +otherwise. For this to work, there must be no separators between the JSON +objects or arrays, instead they must be concatenated back-to-back. If +an error occurs, an exception will be raised as in the scalar context +case. Note that in this case, any previously-parsed JSON texts will be +lost. + +=item $lvalue_string = $json->incr_text + +This method returns the currently stored JSON fragment as an lvalue, that +is, you can manipulate it. This I works when a preceding call to +C in I successfully returned an object. Under +all other circumstances you must not call this function (I mean it. +although in simple tests it might actually work, it I fail under +real world conditions). As a special exception, you can also call this +method before having parsed anything. + +This function is useful in two cases: a) finding the trailing text after a +JSON object or b) parsing multiple JSON objects separated by non-JSON text +(such as commas). + +In Perl 5.005, C attribute is not available. +You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + +=item $json->incr_skip + +This will reset the state of the incremental parser and will remove the +parsed text from the input buffer. This is useful after C +died, in which case the input buffer and incremental parser state is left +unchanged, to skip the text parsed so far and to reset the parse state. + +=back + + + +=head1 JSON::PP OWN METHODS + +=head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + +If C<$enable> is true (or missing), then C will accept +JSON strings quoted by single quotations that are invalid JSON +format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + +As same as the C option, this option may be used to parse +application-specific files written by humans. + + +=head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + +If C<$enable> is true (or missing), then C will accept +bare keys of JSON object that are invalid JSON format. + +As same as the C option, this option may be used to parse +application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + +=head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + +If C<$enable> is true (or missing), then C will convert +the big integer Perl cannot handle as integer into a L +object and convert a floating number (any) into a L. + +On the contary, C converts C objects and C +objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + +See to L aboout the normal conversion of JSON number. + +=head2 loose + + $json = $json->loose([$enable]) + +The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings +and the module doesn't allow to C to these (except for \x2f). +If C<$enable> is true (or missing), then C will accept these +unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + +See L. + +=head2 escape_slash + + $json = $json->escape_slash([$enable]) + +According to JSON Grammar, I (U+002F) is escaped. But default +JSON::PP (as same as JSON::XS) encodes strings without escaping slash. + +If C<$enable> is true (or missing), then C will escape slashes. + +=head2 (OBSOLETED)as_nonblessed + + $json = $json->as_nonblessed + +(OBSOLETED) If C<$enable> is true (or missing), then C will convert +a blessed hash reference or a blessed array reference (contains +other blessed references) into JSON members and arrays. + +This feature is effective only when C is enable. + +=head2 indent_length + + $json = $json->indent_length($length) + +JSON::XS indent space length is 3 and cannot be changed. +JSON::PP set the indent space length with the given $length. +The default is 3. The acceptable range is 0 to 15. + +=head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + +If $function_name or $subroutine_ref are set, its sort routine are used +in encoding JSON objects. + + $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } + +As the sorting routine runs in the JSON::PP scope, the given +subroutine name and the special variables C<$a>, C<$b> will begin +'JSON::PP::'. + +If $integer is set, then the effect is same as C on. + +=head1 INTERNAL + +For developers. + +=over + +=item PP_encode_box + +Returns + + { + depth => $depth, + indent_count => $indent_count, + } + + +=item PP_decode_box + +Returns + + { + text => $text, + at => $at, + ch => $ch, + len => $len, + is_utf8 => $is_utf8, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + +=back + +=head1 MAPPING + +See to L. + + +=head1 UNICODE HANDLING ON PERLS + +If you do not know about Unicode on Perl well, +please check L. + +=head2 Perl 5.8 and later + +Perl can handle Unicode and the JSON::PP de/encode methods also work properly. + + $json->allow_nonref->encode(chr hex 3042); + $json->allow_nonref->encode(chr hex 12345); + +Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. + + $json->allow_nonref->decode('"\u3042"'); + $json->allow_nonref->decode('"\ud808\udf45"'); + +Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. + +Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, +so JSON::PP wraps the C with a subroutine. Thus JSON::PP works slow in the versions. + + +=head2 Perl 5.6 + +Perl can handle Unicode and the JSON::PP de/encode methods also work. + +=head2 Perl 5.005 + +Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. +That means the unicode handling is not available. + +In encoding, + + $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. + $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. + +Returns C and C, as C takes a value more than 255, it treats +as C<$value % 256>, so the above codes are equivalent to : + + $json->allow_nonref->encode(chr 66); + $json->allow_nonref->encode(chr 69); + +In decoding, + + $json->decode('"\u00e3\u0081\u0082"'); + +The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded +japanese character (C). +And if it is represented in Unicode code point, C. + +Next, + + $json->decode('"\u3042"'); + +We ordinary expect the returned value is a Unicode character C. +But here is 5.005 world. This is C<0xE3 0x81 0x82>. + + $json->decode('"\ud808\udf45"'); + +This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. + + +=head1 TODO + +=over + +=item speed + +=item memory saving + +=back + + +=head1 SEE ALSO + +Most of the document are copied and modified from JSON::XS doc. + +L + +RFC4627 (L) + +=head1 AUTHOR + +Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2008 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut Index: /unk/extlib/JSON/Converter.pm =================================================================== --- /trunk/extlib/JSON/Converter.pm (revision 1098) +++ (revision ) @@ -1,269 +1,0 @@ -package JSON::Converter; -############################################################################## - -use Carp; - -$JSON::Converter::VERSION = 0.995; - -############################################################################## - -sub new { - my $class = shift; - bless {indent => 2, pretty => 0, delimiter => 2, @_}, $class; -} - - -sub objToJson { - my $self = shift; - my $obj = shift; - my $opt = shift; - - local(@{$self}{qw/autoconv execcoderef skipinvalid/}); - local(@{$self}{qw/pretty indent delimiter/}); - - $self->_initConvert($opt); - - return $self->toJson($obj); -} - - -sub toJson { - my ($self, $obj) = @_; - - if(ref($obj) eq 'HASH'){ - return $self->hashToJson($obj); - } - elsif(ref($obj) eq 'ARRAY'){ - return $self->arrayToJson($obj); - } - else{ - return; - } -} - - -sub hashToJson { - my $self = shift; - my $obj = shift; - my ($k,$v); - my %res; - - my ($pre,$post) = $self->_upIndent() if($self->{pretty}); - - if(grep { $_ == $obj } @{ $self->{_stack_myself} }){ - die "circle ref!"; - } - - push @{ $self->{_stack_myself} },$obj; - - for my $k (keys %$obj){ - my $v = $obj->{$k}; - if(ref($v) eq "HASH"){ - $res{$k} = $self->hashToJson($v); - } - elsif(ref($v) eq "ARRAY"){ - $res{$k} = $self->arrayToJson($v); - } - else{ - $res{$k} = $self->valueToJson($v); - } - } - - pop @{ $self->{_stack_myself} }; - - $self->_downIndent() if($self->{pretty}); - - if($self->{pretty}){ - my $del = $self->{_delstr}; - return "{$pre" - . join(",$pre", map { _stringfy($_) . $del .$res{$_} } keys %res) - . "$post}"; - } - else{ - return '{'. join(',',map { _stringfy($_) .':' .$res{$_} } keys %res) .'}'; - } - -} - - -sub arrayToJson { - my $self = shift; - my $obj = shift; - my @res; - - my ($pre,$post) = $self->_upIndent() if($self->{pretty}); - - if(grep { $_ == $obj } @{ $self->{_stack_myself} }){ - die "circle ref!"; - } - - push @{ $self->{_stack_myself} },$obj; - - for my $v (@$obj){ - if(ref($v) eq "HASH"){ - push @res,$self->hashToJson($v); - } - elsif(ref($v) eq "ARRAY"){ - push @res,$self->arrayToJson($v); - } - else{ - push @res,$self->valueToJson($v); - } - } - - pop @{ $self->{_stack_myself} }; - - $self->_downIndent() if($self->{pretty}); - - if($self->{pretty}){ - return "[$pre" . join(",$pre" ,@res) . "$post]"; - } - else{ - return '[' . join(',' ,@res) . ']'; - } -} - - -sub valueToJson { - my $self = shift; - my $value = shift; - - return 'null' if(!defined $value); - - if($self->{autoconv} and !ref($value)){ - return $value if($value =~ /^-?(?:0|[1-9][\d]*)(?:\.[\d]+)?$/); - return 'true' if($value =~ /^true$/i); - return 'false' if($value =~ /^false$/i); - } - - if(! ref($value) ){ - return _stringfy($value) - } - elsif($self->{execcoderef} and ref($value) eq 'CODE'){ - my $ret = $value->(); - return 'null' if(!defined $ret); - return $self->toJson($ret) if(ref($ret)); - return _stringfy($ret); - } - elsif( ! UNIVERSAL::isa($value, 'JSON::NotString') ){ - die "Invalid value" unless($self->{skipinvalid}); - return 'null'; - } - - return defined $value->{value} ? $value->{value} : 'null'; -} - - -sub _stringfy { - my $arg = shift; - my $l = length $arg; - my $s = '"'; - my $i = 0; - - while($i < $l){ - my $c = substr($arg,$i++,1); - if($c ge ' '){ - $c =~ s{(["\\])}{\\$1}; - $s .= $c; - } - elsif($c =~ tr/\n\r\t\f\b/nrtfb/){ - $s .= '\\' . $c; - } - else{ - $s .= '\\u00' . unpack('H2',$c); - } - } - - return $s . '"'; -} - - -############################################################################## - -sub _initConvert { - my $self = shift; - my %opt = %{ $_[0] } if(@_ > 0 and ref($_[0]) eq 'HASH'); - - $self->{autoconv} = $JSON::AUTOCONVERT if(!defined $self->{autoconv}); - $self->{execcoderef} = $JSON::ExecCoderef if(!defined $self->{execcoderef}); - $self->{skipinvalid} = $JSON::SkipInvalid if(!defined $self->{skipinvalid}); - - $self->{pretty} = $JSON::Pretty if(!defined $self->{pretty}); - $self->{indent} = $JSON::Indent if(!defined $self->{indent}); - $self->{delimiter} = $JSON::Delimiter if(!defined $self->{delimiter}); - - for my $name (qw/autoconv execcoderef skipinvalid pretty indent delimiter/){ - $self->{$name} = $opt{$name} if(defined $opt{$name}); - } - - $self->{_stack_myself} = []; - $self->{indent_count} = 0; - - $self->{_delstr} = - $self->{delimiter} ? ($self->{delimiter} == 1 ? ': ' : ' : ') : ':'; - - $self; -} - - -sub _upIndent { - my $self = shift; - my $space = ' ' x $self->{indent}; - my ($pre,$post) = ('',''); - - $post = "\n" . $space x $self->{indent_count}; - - $self->{indent_count}++; - - $pre = "\n" . $space x $self->{indent_count}; - - return ($pre,$post); -} - - -sub _downIndent { $_[0]->{indent_count}--; } - -############################################################################## -1; -__END__ - - -=head1 METHODs - -=over - -=item parse - -alias of C. - -=item objToJson - -convert a passed perl data structure into JSON object. -can't parse bleesed object. - -=item hashToJson - -convert a passed hash into JSON object. - -=item arrayToJson - -convert a passed array into JSON array. - -=item valueToJson - -convert a passed data into a string of JSON. - -=back - -=head1 COPYRIGHT - -makamaka [at] donzoko.net - -This library is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L - -=cut Index: /unk/extlib/JSON/Parser.pm =================================================================== --- /trunk/extlib/JSON/Parser.pm (revision 1098) +++ (revision ) @@ -1,323 +1,0 @@ -package JSON::Parser; - -# -# Perl implementaion of json.js -# http://www.crockford.com/JSON/json.js -# - -use vars qw($VERSION); -use strict; - -$VERSION = 0.932; - -my %escapes = ( # by Jeremy Muhlich - b => "\x8", - t => "\x9", - n => "\xA", - f => "\xC", - r => "\xD", -# '/' => '/', - '\\' => '\\', -); - - -sub new { - my $class = shift; - my $self = {}; - bless $self,$class; -} - - -*jsonToObj = \&parse; - - -{ # PARSE - - my $text; - my $at; - my $ch; - my $len; - - sub parse { - my $self = shift; - $text = shift; - $at = 0; - $ch = ''; - $len = length $text; - value(); - } - - - sub next_chr { - return $ch = undef if($at >= $len); - $ch = substr($text, $at++, 1); - } - - - sub value { - white(); - return object() if($ch eq '{'); - return array() if($ch eq '['); - return string() if($ch eq '"'); - return number() if($ch eq '-'); - return $ch =~ /\d/ ? number() : word(); - } - - - sub string { - my ($i,$s,$t,$u); - $s = ''; - - if($ch eq '"'){ - OUTER: while( defined(next_chr()) ){ - if($ch eq '"'){ - next_chr(); - return $s; - } - elsif($ch eq '\\'){ - next_chr(); - if(exists $escapes{$ch}){ - $s .= $escapes{$ch}; - } - elsif($ch eq 'u'){ - my $u = ''; - for(1..4){ - $ch = next_chr(); - last OUTER if($ch !~ /[\da-fA-F]/); - $u .= $ch; - } - $u =~ s/^00// or error("Bad string"); - $s .= pack('H2',$u); - } - else{ - $s .= $ch; - } - } - else{ - $s .= $ch; - } - } - } - - error("Bad string"); - } - - - sub white { - while( defined $ch ){ - if($ch le ' '){ - next_chr(); - } - elsif($ch eq '/'){ - next_chr(); - if($ch eq '/'){ - 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); - } - elsif($ch eq '*'){ - next_chr(); - while(1){ - if(defined $ch){ - if($ch eq '*'){ - if(defined(next_chr()) and $ch eq '/'){ - next_chr(); - last; - } - } - else{ - next_chr(); - } - } - else{ - error("Unterminated comment"); - } - } - next; - } - else{ - error("Syntax error (whitespace)"); - } - } - else{ - last; - } - } - } - - - sub object { - my $o = {}; - my $k; - - if($ch eq '{'){ - next_chr(); - white(); - if($ch eq '}'){ - next_chr(); - return $o; - } - while(defined $ch){ - $k = string(); - white(); - - if($ch ne ':'){ - last; - } - - next_chr(); - $o->{$k} = value(); - white(); - - if($ch eq '}'){ - next_chr(); - return $o; - } - elsif($ch ne ','){ - last; - } - next_chr(); - white(); - } - - error("Bad object"); - } - } - - - sub word { - my $word = substr($text,$at-1,4); - - if($word eq 'true'){ - $at += 3; - next_chr; - return bless {value => 'true'}, 'JSON::NotString' - } - elsif($word eq 'null'){ - $at += 3; - next_chr; - return bless {value => undef}, 'JSON::NotString' - } - elsif($word eq 'fals'){ - $at += 3; - if(substr($text,$at,1) eq 'e'){ - $at++; - next_chr; - return bless {value => 'false'}, 'JSON::NotString' - } - } - - error("Syntax error (word)"); - } - - - sub number { - my $n = ''; - my $v; - - if($ch eq '0'){ - my $peek = substr($text,$at,1); - my $hex = $peek =~ /[xX]/; - - if($hex){ - ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); - } - else{ - ($n) = ( substr($text, $at) =~ /^([0-7]+)/); - } - - if(defined $n and length($n)){ - $at += length($n) + $hex; - next_chr; - return $hex ? hex($n) : oct($n); - } - } - - if($ch eq '-'){ - $n = '-'; - next_chr; - } - - while($ch =~ /\d/){ - $n .= $ch; - next_chr; - } - - if($ch eq '.'){ - $n .= '.'; - while(defined(next_chr) and $ch =~ /\d/){ - $n .= $ch; - } - } - - $v .= $n; - - return $v; - } - - - sub array { - my $a = []; - - if($ch eq '['){ - next_chr(); - white(); - if($ch eq ']'){ - next_chr(); - return $a; - } - while(defined($ch)){ - push @$a, value(); - white(); - if($ch eq ']'){ - next_chr(); - return $a; - } - elsif($ch ne ','){ - last; - } - next_chr(); - white(); - } - } - - error("Bad array"); - } - - - sub error { - my $error = shift; - die "$error at $at in $text."; - } - -} # PARSE - - - -package JSON::NotString; - -use overload ( - '""' => sub { $_[0]->{value} }, - 'bool' => sub { - ! defined $_[0]->{value} ? undef - : $_[0]->{value} eq 'false' ? 0 : 1; - }, -); - -1; - -__END__ - -=head1 SEE ALSO - -L - -This module is an implementation of L. - - -=head1 COPYRIGHT - -makamaka [at] donzoko.net - -This library is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=cut Index: /trunk/extlib/JSON.pm =================================================================== --- /trunk/extlib/JSON.pm (revision 1098) +++ /trunk/extlib/JSON.pm (revision 3531) @@ -1,423 +1,2045 @@ package JSON; + use strict; +use Carp (); use base qw(Exporter); -use JSON::Parser; -use JSON::Converter; - -@JSON::EXPORT = qw(objToJson jsonToObj); - -use vars qw($AUTOCONVERT $VERSION - $ExecCoderef $SkipInvalid $Pretty $Indent $Delimiter); - -$VERSION = 0.99; - -$AUTOCONVERT = 1; -$ExecCoderef = 0; -$SkipInvalid = 0; -$Indent = 2; # (pretty-print) -$Delimiter = 2; # (pretty-print) 0 => ':', 1 => ': ', 2 => ' : ' - -my $parser; # JSON => Perl -my $conv; # Perl => JSON - -############################################################################## -# CONSTRCUTOR - JSON objects delegate all processes -# to JSON::Converter and JSON::Parser. -############################################################################## - -sub new { - my $class = shift; - my %opt = @_; - bless { - conv => undef, # JSON::Converter [perl => json] - parser => undef, # JSON::Parser [json => perl] - # below fields are for JSON::Converter - autoconv => 1, - skipinvalid => 0, - execcoderef => 0, - pretty => 0, # pretty-print mode switch - indent => 2, # for pretty-print - delimiter => 2, # for pretty-print - # overwrite - %opt, - }, $class; +@JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json); + +BEGIN { + $JSON::VERSION = '2.12'; + $JSON::DEBUG = 0 unless (defined $JSON::DEBUG); } - -############################################################################## -# METHODS -############################################################################## +my $Module_XS = 'JSON::XS'; +my $Module_PP = 'JSON::PP'; +my $XS_Version = '2.22'; + + +# XS and PP common methods + +my @PublicMethods = qw/ + ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed filter_json_object filter_json_single_key_object + shrink max_depth max_size encode decode decode_prefix allow_unknown +/; + +my @Properties = qw/ + ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed shrink max_depth max_size allow_unknown +/; + +my @XSOnlyMethods = qw//; # Currently nothing + +my @PPOnlyMethods = qw/ + indent_length sort_by + allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed +/; # JSON::PP specific + + +# used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently) +my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die. +my $_INSTALL_ONLY = 2; # Don't call _set_methods() +my $_ALLOW_UNSUPPORTED = 0; +my $_UNIV_CONV_BLESSED = 0; + + +# Check the environment variable to decide worker module. + +unless ($JSON::Backend) { + $JSON::DEBUG and Carp::carp("Check used worker module..."); + + my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1; + + if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) { + _load_xs($_INSTALL_DONT_DIE) or _load_pp(); + } + elsif ($backend eq '0' or $backend eq 'JSON::PP') { + _load_pp(); + } + elsif ($backend eq '2' or $backend eq 'JSON::XS') { + _load_xs(); + } + else { + Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid."; + } +} + + +sub import { + my $pkg = shift; + my @what_to_export; + my $no_export; + + for my $tag (@_) { + if ($tag eq '-support_by_pp') { + if (!$_ALLOW_UNSUPPORTED++) { + JSON::Backend::XS + ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS); + } + next; + } + elsif ($tag eq '-no_export') { + $no_export++, next; + } + elsif ( $tag eq '-convert_blessed_universally' ) { + eval q| + require B; + *UNIVERSAL::TO_JSON = sub { + my $b_obj = B::svref_2object( $_[0] ); + return $b_obj->isa('B::HV') ? { %{ $_[0] } } + : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] + : undef + ; + } + | if ( !$_UNIV_CONV_BLESSED++ ); + next; + } + push @what_to_export, $tag; + } + + return if ($no_export); + + __PACKAGE__->export_to_level(1, $pkg, @what_to_export); +} + + +# OBSOLETED sub jsonToObj { - my $self = shift; - my $js = shift; - - if(!ref($self)){ # class method - $js = $self; - $parser ||= new JSON::Parser; - $parser->jsonToObj($js); - } - else{ # instance method - $self->{parser} ||= ($parser ||= JSON::Parser->new); - $self->{parser}->jsonToObj($js); - } + my $alternative = 'from_json'; + if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { + shift @_; $alternative = 'decode'; + } + Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead."; + return JSON::from_json(@_); +}; + +sub objToJson { + my $alternative = 'to_json'; + if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { + shift @_; $alternative = 'encode'; + } + Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead."; + JSON::to_json(@_); +}; + + +# INTERFACES + +sub to_json ($@) { + my $json = new JSON; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + $json->encode($_[0]); } -sub objToJson { - my $self = shift || return; - my $obj = shift; - - if(ref($self) !~ /JSON/){ # class method - my $opt = __PACKAGE__->_getDefaultParms($obj); - $obj = $self; - $conv ||= JSON::Converter->new(); - $conv->objToJson($obj, $opt); - } - else{ # instance method - my $opt = $self->_getDefaultParms($_[0]); - $self->{conv} - ||= JSON::Converter->new( %$opt ); - $self->{conv}->objToJson($obj, $opt); - } +sub from_json ($@) { + my $json = new JSON; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + return $json->decode( $_[0] ); } -####################### - -sub _getDefaultParms { - my $self = shift; - my $opt = shift; - my $params; - - if(ref($self)){ # instance - my @names = qw(pretty indent delimiter autoconv); - my ($pretty, $indent, $delimiter, $autoconv) = @{$self}{ @names }; - $params = { - pretty => $pretty, indent => $indent, - delimiter => $delimiter, autoconv => $autoconv, - }; - } - else{ # class - $params = {pretty => $Pretty, indent => $Indent, delimiter => $Delimiter}; - } - - if($opt and ref($opt) eq 'HASH'){ %$params = ( %$opt ); } - - return $params; +sub true { $JSON::true } + +sub false { $JSON::false } + +sub null { undef; } + + +sub require_xs_version { $XS_Version; } + +sub backend { + my $proto = shift; + $JSON::Backend; } -############################################################################## -# ACCESSOR -############################################################################## - -sub autoconv { $_[0]->{autoconv} = $_[1] if(defined $_[1]); $_[0]->{autoconv} } - -sub pretty { $_[0]->{pretty} = $_[1] if(defined $_[1]); $_[0]->{pretty} } - -sub indent { $_[0]->{indent} = $_[1] if(defined $_[1]); $_[0]->{indent} } - -sub delimiter { $_[0]->{delimiter} = $_[1] if(defined $_[1]); $_[0]->{delimiter} } - -############################################################################## -# NON STRING DATA -############################################################################## - -# See JSON::Parser for JSON::NotString. - -sub Number { - my $num = shift; - if(!defined $num or $num !~ /^-?(0|[1-9][\d]*)(\.[\d]+)?$/){ - return undef; - } - bless {value => $num}, 'JSON::NotString'; +#*module = *backend; + + +sub is_xs { + return $_[0]->module eq $Module_XS; } -sub True { - bless {value => 'true'}, 'JSON::NotString'; + +sub is_pp { + return $_[0]->module eq $Module_PP; } -sub False { - bless {value => 'false'}, 'JSON::NotString'; + +sub pureperl_only_methods { @PPOnlyMethods; } + + +sub property { + my ($self, $name, $value) = @_; + + if (@_ == 1) { + my %props; + for $name (@Properties) { + my $method = 'get_' . $name; + if ($name eq 'max_size') { + my $value = $self->$method(); + $props{$name} = $value == 1 ? 0 : $value; + next; + } + $props{$name} = $self->$method(); + } + return \%props; + } + elsif (@_ > 3) { + Carp::croak('property() can take only the option within 2 arguments.'); + } + elsif (@_ == 2) { + if ( my $method = $self->can('get_' . $name) ) { + if ($name eq 'max_size') { + my $value = $self->$method(); + return $value == 1 ? 0 : $value; + } + $self->$method(); + } + } + else { + $self->$name($value); + } + } -sub Null { - bless {value => undef}, 'JSON::NotString'; + + +# INTERNAL + +sub _load_xs { + my $opt = shift; + + $JSON::DEBUG and Carp::carp "Load $Module_XS."; + + # if called after install module, overload is disable.... why? + JSON::Boolean::_overrride_overload($Module_XS); + JSON::Boolean::_overrride_overload($Module_PP); + + eval qq| + use $Module_XS $XS_Version (); + |; + + if ($@) { + if (defined $opt and $opt & $_INSTALL_DONT_DIE) { + $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)"; + return 0; + } + Carp::croak $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $JSON::Backend = $Module_XS ); + my $data = join("", ); # this code is from Jcode 2.xx. + close(DATA); + eval $data; + JSON::Backend::XS->init; + } + + return 1; +}; + + +sub _load_pp { + my $opt = shift; + + $JSON::DEBUG and Carp::carp "Load $Module_PP."; + + # if called after install module, overload is disable.... why? + JSON::Boolean::_overrride_overload($Module_XS); + JSON::Boolean::_overrride_overload($Module_PP); + + eval qq| require $Module_PP |; + if ($@) { + Carp::croak $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $JSON::Backend = $Module_PP ); + JSON::Backend::PP->init; + } +}; + + +sub _set_module { + my $module = shift; + + local $^W; + no strict qw(refs); + + $JSON::true = ${"$module\::true"}; + $JSON::false = ${"$module\::false"}; + + push @JSON::ISA, $module; + push @{"$module\::Boolean::ISA"}, qw(JSON::Boolean); + + *{"JSON::is_bool"} = \&{"$module\::is_bool"}; + + for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) { + *{"JSON::$method"} = sub { + Carp::carp("$method is not supported in $module."); + $_[0]; + }; + } + + return 1; } -############################################################################## + + +# +# JSON Boolean +# + +package JSON::Boolean; + +my %Installed; + +sub _overrride_overload { + return if ($Installed{ $_[0] }++); + + my $boolean = $_[0] . '::Boolean'; + + eval sprintf(q| + package %s; + use overload ( + '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' }, + 'eq' => sub { + my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]); + if ($op eq 'true' or $op eq 'false') { + return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op; + } + else { + return $obj ? 1 == $op : 0 == $op; + } + }, + ); + |, $boolean); + + if ($@) { Carp::croak $@; } + + return 1; +} + + +# +# Helper classes for Backend Module (PP) +# + +package JSON::Backend::PP; + +sub init { + local $^W; + no strict qw(refs); + *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"}; + *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"}; + *{"JSON::PP::is_xs"} = sub { 0 }; + *{"JSON::PP::is_pp"} = sub { 1 }; + return 1; +} + +# +# To save memory, the below lines are read only when XS backend is used. +# + +package JSON; + +1; +__DATA__ + + +# +# Helper classes for Backend Module (XS) +# + +package JSON::Backend::XS; + +use constant INDENT_LENGTH_FLAG => 15 << 12; + +use constant UNSUPPORTED_ENCODE_FLAG => { + ESCAPE_SLASH => 0x00000010, + ALLOW_BIGNUM => 0x00000020, + AS_NONBLESSED => 0x00000040, + EXPANDED => 0x10000000, # for developer's +}; + +use constant UNSUPPORTED_DECODE_FLAG => { + LOOSE => 0x00000001, + ALLOW_BIGNUM => 0x00000002, + ALLOW_BAREKEY => 0x00000004, + ALLOW_SINGLEQUOTE => 0x00000008, + EXPANDED => 0x20000000, # for developer's +}; + + +sub init { + local $^W; + no strict qw(refs); + *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"}; + *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"}; + *{"JSON::XS::is_xs"} = sub { 1 }; + *{"JSON::XS::is_pp"} = sub { 0 }; + return 1; +} + + +sub support_by_pp { + my ($class, @methods) = @_; + + local $^W; + no strict qw(refs); + + push @JSON::Backend::XS::Supportable::ISA, 'JSON'; + + my $pkg = 'JSON::Backend::XS::Supportable'; + + *{JSON::new} = sub { + my $proto = new JSON::XS; $$proto = 0; + bless $proto, $pkg; + }; + + for my $method (@methods) { + my $flag = uc($method); + my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0); + $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0); + + next unless($type); + + $pkg->_make_unsupported_method($method => $type); + } + + push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean); + push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean); + + $JSON::DEBUG and Carp::carp("set -support_by_pp mode."); + + return 1; +} + + + + +# +# Helper classes for XS +# + +package JSON::Backend::XS::Supportable; + + +my $JSON_XS_encode_orignal = \&JSON::XS::encode; +my $JSON_XS_decode_orignal = \&JSON::XS::decode; + +$Carp::Internal{'JSON::Backend::XS::Supportable'} = 1; + +sub _make_unsupported_method { + my ($pkg, $method, $type) = @_; + + local $^W; + no strict qw(refs); + + *{"$pkg\::$method"} = sub { + local $^W; + if (defined $_[1] ? $_[1] : 1) { + ${$_[0]} |= $type; + } + else { + ${$_[0]} &= ~$type; + } + + if (${$_[0]}) { + *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode; + *JSON::XS::decode = \&JSON::Backend::XS::Supportable::_decode; + } + else { + *JSON::XS::encode = $JSON_XS_encode_orignal; + *JSON::XS::decode = $JSON_XS_decode_orignal; + } + + $_[0]; + }; + + *{"$pkg\::get_$method"} = sub { + ${$_[0]} & $type ? 1 : ''; + }; + +} + + +sub _set_for_pp { + require JSON::PP; + my $type = shift; + my $pp = new JSON::PP; + my $prop = $_[0]->property; + + for my $name (keys %$prop) { + $pp->$name( $prop->{$name} ? $prop->{$name} : 0 ); + } + + my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG + : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG; + my $flags = ${$_[0]} || 0; + + for my $name (keys %$unsupported) { + next if ($name eq 'EXPANDED'); # for developer's + my $enable = ($flags & $unsupported->{$name}) ? 1 : 0; + my $method = lc $name; + $pp->$method($enable); + } + + $pp->indent_length( $_[0]->get_indent_length ); + + return $pp; +} + + +sub _encode { # using with PP encod + _set_for_pp('encode' => @_)->encode($_[1]); +} + + +sub _decode { # if unsupported-flag is set, use PP + _set_for_pp('decode' => @_)->decode($_[1]); +} + + +sub decode_prefix { # if unsupported-flag is set, use PP + _set_for_pp('decode' => @_)->decode_prefix($_[1]); +} + + +sub get_indent_length { + ${$_[0]} << 4 >> 16; +} + + +sub indent_length { + my $length = $_[1]; + + if (!defined $length or $length > 15 or $length < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + local $^W; + $length <<= 12; + ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG; + ${$_[0]} |= $length; + *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode; + } + + $_[0]; +} + + 1; __END__ -=pod - =head1 NAME -JSON - parse and convert to JSON (JavaScript Object Notation). +JSON - JSON (JavaScript Object Notation) encoder/decoder =head1 SYNOPSIS - use JSON; + use JSON; # imports encode_json, decode_json, to_json and from_json. - $obj = { - id => ["foo", "bar", { aa => 'bb'}], - hoge => 'boge' - }; + $json_text = to_json($perl_scalar); + $perl_scalar = from_json($json_text); - $js = objToJson($obj); - # this is {"id":["foo","bar",{"aa":"bb"}],"hoge":"boge"}. - $obj = jsonToObj($js); - # the data structure was restored. + # option-acceptable + $json_text = to_json($perl_scalar, {ascii => 1}); + $perl_scalar = from_json($json_text, {utf8 => 1}); # OOP + $json = new JSON; - my $json = new JSON; - - $obj = {id => 'foo', method => 'echo', params => ['a','b']} - $js = $json->objToJson($obj); - $obj = $json->jsonToObj($js); + $json_text = $json->encode($perl_scalar); + $perl_scalar = $json->decode($json_text); # pretty-printing - $js = $json->objToJson($obj, {pretty => 1, indent => 2}); - - $json = JSON->new(pretty => 1, delimiter => 0); - $json->objToJson($obj); + $json_text = $json->pretty->encode($perl_scalar); + + # simple interface + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + + # If you want to use PP only support features, call with '-support_by_pp' + # When XS unsupported feature is enable, using PP de/encode. + + use JSON -support_by_pp; + + +=head1 VERSION + + 2.11 + +This version is compatible with JSON::XS B<2.21>. =head1 DESCRIPTION -This module converts between JSON (JavaScript Object Notation) and Perl -data structure into each other. -For JSON, See to http://www.crockford.com/JSON/. - - -=head1 METHODS + ************************** CAUTION ******************************** + * This is 'JSON module version 2' and there are many differences * + * to version 1.xx * + * Please check your applications useing old version. * + * See to 'INCOMPATIBLE CHANGES TO OLD VERSION' * + ******************************************************************* + +JSON (JavaScript Object Notation) is a simple data format. +See to L and C(L). + +This module converts Perl data structures to JSON and vice versa using either +L or L. + +JSON::XS is the fastest and most proper JSON module on CPAN which must be +compiled and installed in your environment. +JSON::PP is a pure-Perl module which is bundled in this distribution and +has a strong compatibility to JSON::XS. + +This module try to use JSON::XS by default and fail to it, use JSON::PP instead. +So its features completely depend on JSON::XS or JSON::PP. + +See to L. + +To distinguish the module name 'JSON' and the format type JSON, +the former is quoted by CEE (its results vary with your using media), +and the latter is left just as it is. + +Module name : C + +Format type : JSON + +=head2 FEATURES + +=over + +=item * correct unicode handling + +This module (i.e. backend modules) knows how to handle Unicode, documents +how and when it does so, and even documents what "correct" means. + +Even though there are limitations, this feature is available since Perl version 5.6. + +JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions +C sholud call JSON::PP as the backend which can be used since Perl 5.005. + +With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem, +JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available. +See to L for more information. + +See also to L +and L. + + +=item * round-trip integrity + +When you serialise a perl data structure using only data types supported by JSON, +the deserialised data structure is identical on the Perl level. +(e.g. the string "2.0" doesn't suddenly become "2" just because it looks +like a number). There minor I exceptions to this, read the MAPPING +section below to learn about those. + +=item * strict checking of JSON correctness + +There is no guessing, no generating of illegal JSON texts by default, +and only JSON is accepted as input by default (the latter is a security +feature). + +See to L and L. + +=item * fast + +This module returns a JSON::XS object itself if avaliable. +Compared to other JSON modules and other serialisers such as Storable, +JSON::XS usually compares favourably in terms of speed, too. + +If not avaliable, C returns a JSON::PP object instead of JSON::XS and +it is very slow as pure-Perl. + +=item * simple to use + +This module has both a simple functional interface as well as an +object oriented interface interface. + +=item * reasonably versatile output formats + +You can choose between the most compact guaranteed-single-line format possible +(nice for simple line-based protocols), a pure-ASCII format (for when your transport +is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed +format (for when you want to read that stuff). Or you can combine those features +in whatever way you like. + +=back + +=head1 FUNCTIONAL INTERFACE + +Some documents are copied and modified from L. +C and C are additional functions. + +=head2 to_json + + $json_text = to_json($perl_scalar) + +Converts the given Perl data structure to a json string. + +This function call is functionally identical to: + + $json_text = JSON->new->encode($perl_scalar) + +Takes a hash reference as the second. + + $json_text = to_json($perl_scalar, $flag_hashref) + +So, + + $json_text = encode_json($perl_scalar, {utf8 => 1, pretty => 1}) + +equivalent to: + + $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar) + + +=head2 from_json + + $perl_scalar = from_json($json_text) + +The opposite of C: expects a json string and tries +to parse it, returning the resulting reference. + +This function call is functionally identical to: + + $perl_scalar = JSON->decode($json_text) + +Takes a hash reference as the second. + + $perl_scalar = from_json($json_text, $flag_hashref) + +So, + + $perl_scalar = from_json($json_text, {utf8 => 1}) + +equivalent to: + + $perl_scalar = JSON->new->utf8(1)->decode($json_text) + +=head2 encode_json + + $json_text = encode_json $perl_scalar + +Converts the given Perl data structure to a UTF-8 encoded, binary string. + +This function call is functionally identical to: + + $json_text = JSON->new->utf8->encode($perl_scalar) + +=head2 decode_json + + $perl_scalar = decode_json $json_text + +The opposite of C: expects an UTF-8 (binary) string and tries +to parse that as an UTF-8 encoded JSON text, returning the resulting +reference. + +This function call is functionally identical to: + + $perl_scalar = JSON->new->utf8->decode($json_text) + +=head2 JSON::is_bool + + $is_boolean = JSON::is_bool($scalar) + +Returns true if the passed scalar represents either JSON::true or +JSON::false, two constants that act like C<1> and C<0> respectively +and are also used to represent JSON C and C in Perl strings. + +=head2 JSON::true + +Returns JSON true value which is blessed object. +It C JSON::Boolean object. + +=head2 JSON::false + +Returns JSON false value which is blessed object. +It C JSON::Boolean object. + +=head2 JSON::null + +Returns C. + +See L, below, for more information on how JSON values are mapped to +Perl. + +=head1 COMMON OBJECT-ORIENTED INTERFACE + + +=head2 new + + $json = new JSON + +Returns a new C object inherited from either JSON::XS or JSON::PP +that can be used to de/encode JSON strings. + +All boolean flags described below are by default I. + +The mutators for flags all return the JSON object again and thus calls can +be chained: + + my $json = JSON->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + +=head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + +If $enable is true (or missing), then the encode method will not generate characters outside +the code range 0..127. Any Unicode characters outside that range will be escaped using either +a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + +If $enable is false, then the encode method will not escape Unicode characters unless +required by the JSON syntax or other flags. This results in a faster and more compact format. + +This feature depends on the used Perl version and environment. + +See to L if the backend is PP. + + JSON->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + +=head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + +If $enable is true (or missing), then the encode method will encode the resulting JSON +text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + +If $enable is false, then the encode method will not escape Unicode characters +unless required by the JSON syntax or other flags. + + JSON->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + +=head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + +If $enable is true (or missing), then the encode method will encode the JSON result +into UTF-8, as required by many protocols, while the decode method expects to be handled +an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any +characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + +In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 +encoding families, as described in RFC4627. + +If $enable is false, then the encode method will return the JSON string as a (non-encoded) +Unicode string, while decode expects thus a Unicode string. Any decoding or encoding +(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + +Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); + +Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + +See to L if the backend is PP. + + +=head2 pretty + + $json = $json->pretty([$enable]) + +This enables (or disables) all of the C, C and +C (and in the future possibly more) flags in one call to +generate the most readable (or most compact) form possible. + +Equivalent to: + + $json->indent->space_before->space_after + +The indent space length is three and JSON::XS cannot change the indent +space length. + +=head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + +If C<$enable> is true (or missing), then the C method will use a multiline +format as output, putting every array member or object/hash key-value pair +into its own line, identing them properly. + +If C<$enable> is false, no newlines or indenting will be produced, and the +resulting JSON text is guarenteed not to contain any C. + +This setting has no effect when decoding JSON texts. + +The indent space length is three. +With JSON::PP, you can also access C to change indent space length. + + +=head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + +If C<$enable> is true (or missing), then the C method will add an extra +optional space before the C<:> separating keys from values in JSON objects. + +If C<$enable> is false, then the C method will not add any extra +space at those places. + +This setting has no effect when decoding JSON texts. + +Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + +=head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + +If C<$enable> is true (or missing), then the C method will add an extra +optional space after the C<:> separating keys from values in JSON objects +and extra whitespace after the C<,> separating key-value pairs and array +members. + +If C<$enable> is false, then the C method will not add any extra +space at those places. + +This setting has no effect when decoding JSON texts. + +Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + +=head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + +If C<$enable> is true (or missing), then C will accept some +extensions to normal JSON syntax (see below). C will not be +affected in anyway. I. I suggest only to use this option to +parse application-specific files written by humans (configuration files, +resource files etc.) + +If C<$enable> is false (the default), then C will only accept +valid JSON texts. + +Currently accepted extensions are: =over 4 -=item new() - -=item new( %options ) - -returns a JSON object. The object delegates the converting and parsing process -to L and L. - - my $json = new JSON; - -C can take some options. - - my $json = new JSON (autoconv => 0, pretty => 1); - -Following options are supported: +=item * list items can have an end-comma + +JSON I array elements and key-value pairs with commas. This +can be annoying if you write JSON texts manually and want to be able to +quickly append elements, so this extension accepts comma at the end of +such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + +=item * shell-style '#'-comments + +Whenever JSON allows whitespace, shell-style comments are additionally +allowed. They are terminated by the first carriage-return or line-feed +character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + +=back + + +=head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + +If C<$enable> is true (or missing), then the C method will output JSON objects +by sorting their keys. This is adding a comparatively high overhead. + +If C<$enable> is false, then the C method will output key-value +pairs in the order Perl stores them (which will likely change between runs +of the same script). + +This option is useful if you want the same data structure to be encoded as +the same JSON text (given the same overall settings). If it is disabled, +the same hash might be encoded differently even if contains the same data, +as key-value pairs have no inherent ordering in Perl. + +T